New upstream version 19.9

14 files changed, 199 insertions, 45 deletions

diff --git a/tools/dup.scm b/tools/dup.scm
index 217dc8c..f3997dd 100644
--- a/tools/dup.scm
+++ b/tools/dup.scm
@@ -4,8 +4,6 @@
 ;;;    "alloc-lines" is any number bigger than the number of lines in "file"
 ;;;    (dups 16 "s7.c" 91000) finds all 16-line matches in s7.c which (we wish) has less than 91000 lines in all
 
-;(set! (*s7* 'heap-size) (* 2 1024000))
-
 (define dups 
   (let ((unique #f))
 
@@ -123,7 +121,7 @@
 			  (format *stderr* "~%")))))))))))))
 
 (dups 16 "s7.c" 100000)
-;(dups 8 "s7.c" 100000)
+;(dups 12 "s7.c" 100000)
 ;(dups 12 "ffitest.c" 2000)
 ;(dups 8 "ffitest.c" 2000)
 ;(dups 1 "s7test.scm" 105000)
diff --git a/tools/make-index.scm b/tools/make-index.scm
index 53f645b..025f10a 100644
--- a/tools/make-index.scm
+++ b/tools/make-index.scm
@@ -790,6 +790,7 @@
        (make-moog "moog.scm")
        
        (primes.scm "primes.scm")
+       (low-primes.scm "low-primes.scm")
        (snd-clm23.scm "clm23.scm")
        (snd-edit123.scm "edit123.scm")
        (snd-new-effects.scm "new-effects.scm")
diff --git a/tools/tclo.scm b/tools/tclo.scm
index 8de766b..8007c76 100644
--- a/tools/tclo.scm
+++ b/tools/tclo.scm
@@ -1,5 +1,16 @@
 (set! (*s7* 'heap-size) (* 8 1024000))
 
+(define d1-size 200000)
+(define g-size 1000000)
+(define kf-size 30)
+(define k100-size 10000)
+#|
+(define d1-size 0)
+(define g-size 0)
+(define kf-size 30)
+(define k100-size 0)
+|#
+
 (define* (f0 a b)
   (display b #f))
 
@@ -18,7 +29,7 @@
 (define* (f5 (a 1))
   (apply + (list a 2)))
 
-(define* (f6 a . b)
+(define* (f6 a . b)          ; unsafe 
   (apply values (cons a b)))
 
 (define* (f7 (a 1) (b 2))
@@ -47,7 +58,7 @@
   (tfib 35)
   (let ((x 1) (y 2))
     (do ((i 0 (+ i 1)))
-	((= i 200000))
+	((= i d1-size))
       (f0 1 2)
       (f0 x y)
       (f0 :a x)
@@ -92,4 +103,113 @@
 
 (d1)
 
+;;; -------- comparison with non-key case: --------
+
+(define no-key-fib
+   (lambda (n)
+     (if (<= n 2) 1 (+ (no-key-fib (- n 2))
+                       (no-key-fib (- n 1))))))
+
+(define key-fib
+  (lambda* (n)
+    (if (<= n 2) 1 
+	(+ (key-fib :n (- n 2))
+           (key-fib :n (- n 1))))))
+
+(define (f12 a b)
+  (when (> a b)
+    (+ a b)))
+
+(define* (f13 a b)
+  (when (> a b)
+    (+ a b)))
+
+(define* (f14 (a 1) (b 0))
+  (when (> a b)
+    (+ a b)))
+
+
+(define size g-size)
+
+(define (g1)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f12 i i)))
+
+(define (g2)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f13 i i)))
+
+(define (g3)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f13 :a i :b i)))
+
+(define (g4)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f13 :b i :a i)))
+
+(define (g5)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f14)))
+
+(define (g6)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f14 i i)))
+
+(define (g7)
+  (do ((i 0 (+ i 1)))
+      ((= i g-size))
+    (f14 :a i)))
+
+
+;;; -------- 100 key args --------
+
+(define* (k100 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9
+	      a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
+	      a20 a21 a22 a23 a24 a25 a26 a27 a28 a29
+	      a30 a31 a32 a33 a34 a35 a36 a37 a38 a39
+	      a40 a41 a42 a43 a44 a45 a46 a47 a48 a49
+	      a50 a51 a52 a53 a54 a55 a56 a57 a58 a59
+	      a60 a61 a62 a63 a64 a65 a66 a67 a68 a69
+	      a70 a71 a72 a73 a74 a75 a76 a77 a78 a79
+	      a80 a81 a82 a83 a84 a85 a86 a87 a88 a89
+	      a90 a91 a92 a93 a94 a95 a96 a97 a98 a99)
+  (+ a0 a1))
+
+(define (g100)
+  (do ((i 0 (+ i 1)))
+      ((= i k100-size))
+    (k100 :a0 1 :a1 1 :a2 1 :a3 1 :a4 1 :a5 1 :a6 1 :a7 1 :a8 1 :a9 1
+	 :a10 1 :a11 1 :a12 1 :a13 1 :a14 1 :a15 1 :a16 1 :a17 1 :a18 1 :a19 1
+	 :a20 1 :a21 1 :a22 1 :a23 1 :a24 1 :a25 1 :a26 1 :a27 1 :a28 1 :a29 1
+	 :a30 1 :a31 1 :a32 1 :a33 1 :a34 1 :a35 1 :a36 1 :a37 1 :a38 1 :a39 1
+	 :a40 1 :a41 1 :a42 1 :a43 1 :a44 1 :a45 1 :a46 1 :a47 1 :a48 1 :a49 1
+	 :a50 1 :a51 1 :a52 1 :a53 1 :a54 1 :a55 1 :a56 1 :a57 1 :a58 1 :a59 1
+	 :a60 1 :a61 1 :a62 1 :a63 1 :a64 1 :a65 1 :a66 1 :a67 1 :a68 1 :a69 1
+	 :a70 1 :a71 1 :a72 1 :a73 1 :a74 1 :a75 1 :a76 1 :a77 1 :a78 1 :a79 1
+	 :a80 1 :a81 1 :a82 1 :a83 1 :a84 1 :a85 1 :a86 1 :a87 1 :a88 1 :a89 1
+	 :a90 1 :a91 1 :a92 1 :a93 1 :a94 1 :a95 1 :a96 1 :a97 1 :a98 1 :a99 1)))
+
+
+;;; --------------------------------
+(define (kcall)
+  (no-key-fib kf-size)
+  (key-fib kf-size))
+(kcall)
+
+(g1)
+(g2)
+(g3)
+(g4)
+(g5)
+(g6)
+(g7)
+
+(g100)
+
 (exit)
diff --git a/tools/tgen.scm b/tools/tgen.scm
index 488b648..fbb836c 100644
--- a/tools/tgen.scm
+++ b/tools/tgen.scm
@@ -19,7 +19,7 @@
 (set! *clm-file-buffer-size* 16)
 (set! *clm-table-size* 16)
 (set! *clm-clipped* #f)
-;(set! (*s7* 'gc-stats) #t) ; also, unset heap-size is best
+;(set! (*s7* 'gc-stats) #t)
 
 (define start-run (get-internal-real-time))
 (define M (float-vector 0 0 1 10))
diff --git a/tools/thash.scm b/tools/thash.scm
index 1828322..f24c986 100644
--- a/tools/thash.scm
+++ b/tools/thash.scm
@@ -1,4 +1,4 @@
-(set! (*s7* 'heap-size) (* 5 1024000))
+(set! (*s7* 'heap-size) (* 3 1024000))
 ;(set! (*s7* 'gc-stats) 6)
 
 (define (reader)
diff --git a/tools/tmac.scm b/tools/tmac.scm
index cfb0145..ef86aac 100644
--- a/tools/tmac.scm
+++ b/tools/tmac.scm
@@ -51,7 +51,7 @@
     (m5 1 3 4 5)))
 (f5-test)
 
-(define-macro (m61 a b) `(+ ,a ,@b))
+(define-macro (m61 a b) (cons '+ (cons a b)))
 (define (f61-test mx)
   (do ((i 0 (+ i 1)))
       ((= i size))
@@ -86,11 +86,10 @@
 (define (trace-test)
   (let loop ((count 0))
     (if (< count 30000) ; not 'when for old snd timings
-	(begin
-	  (let ((f1 (lambda (x y z) (+ x y z))))
-	    (trace f1) ; op_macro_d I think
-	    (f1 count count count)
-	    (loop (+ count 1)))))))
+	(let ((f1 (lambda (x y z) (+ x y z))))
+	  (trace f1) ; op_macro_d I think
+	  (f1 count count count)
+	  (loop (+ count 1))))))
 
 (trace-test)
 
diff --git a/tools/tmisc.scm b/tools/tmisc.scm
index 107219e..7fe56d9 100644
--- a/tools/tmisc.scm
+++ b/tools/tmisc.scm
@@ -160,4 +160,39 @@
 (mvtest)
 
 
-(exit)
+;;; unlet
+;;; incrementally set all globals to 42 -- check that unlet exprs return the same results
+
+(let* ((syms (symbol-table))
+       (num-syms (length syms))
+       (orig-x (*s7* 'print-length)))
+  
+  (define (unlet-test i)
+    (with-let (unlet)
+      (catch #t
+	(lambda ()
+	  (eval `(define ,(syms i) 42))
+	  (when (procedure? (symbol->value (syms i) (rootlet)))
+	    (with-let (unlet)
+	      (eval `(set! ,(syms i) 42) (rootlet)))))
+	(lambda (type info)
+	  ;(format *stderr* "~S unchanged: ~S~%" (syms i) (apply format #f info))
+	  #f)))
+    
+    (with-let (unlet)
+      (do ((k 0 (+ k 1)))
+	  ((= k 1000))
+	(catch #t
+	  (lambda ()
+	    (let ((x (+ k (*s7* 'print-length))))
+	      (unless (eqv? x (+ k orig-x))
+		(format *stderr* "sym: ~S, x: ~S, orig: ~S~%" (syms i) x (+ k orig-x)))))
+	  (lambda (type info)
+	    (format *stderr* "sym: ~S, error: ~S~%" (syms i) (apply format #f info)))))))
+  
+  (do ((i 0 (#_+ i 1))) ; "do" is not a procedure (see above) so it's not in danger here
+      ((#_= i num-syms))
+    (unlet-test i)))
+
+
+(#_exit) ; we just clobbered exit above
diff --git a/tools/tpeak.scm b/tools/tpeak.scm
index 1aac941..a16b89e 100644
--- a/tools/tpeak.scm
+++ b/tools/tpeak.scm
@@ -1,5 +1,6 @@
-(if (not (provided? 'snd-peak-phases.scm)) (load "peak-phases.scm"))
-(load "primes.scm")
+(unless (provided? 'snd-peak-phases.scm) 
+  (load "low-primes.scm")
+  (load "peak-phases.scm"))
 
 (define (get-best choice n)
   (let ((val (vector-ref (case choice 
diff --git a/tools/trclo.scm b/tools/trclo.scm
index 91e5f81..82c1aa7 100644
--- a/tools/trclo.scm
+++ b/tools/trclo.scm
@@ -384,13 +384,13 @@
 
 (define (lcond1 x y)
   (let ((z (+ x y)))
-    (cond ((= 0 z) pi)
+    (cond ((= z 0) pi)
 	  ((< z 0) 'oops)
 	  (else (lcond1 (- x 1) (- y 1))))))
 
 (define (lcond2 x)
   (let ((z (+ x 1)))
-    (cond ((= 0 z) pi)
+    (cond ((= z 0) pi)
 	  ((< z 0) 'oops)
 	  (else (lcond2 (- x 1))))))
 
@@ -398,13 +398,13 @@
 
 (define (lcond3 x y)
   (let ((z (+ x y)))
-    (cond ((= 0 z) pi)
+    (cond ((= z 0) pi)
 	  ((< z 0) (lcond3 (+ x 1) y))
 	  (else (lcond3 (- x 1) y)))))
 
 (define (lcond4 x y z)
   (let ((a (+ x y z)))
-    (cond ((= 0 z) pi)
+    (cond ((= z 0) pi)
 	  (else (lcond4 x (- y 1) (- z 1))))))
 
 (define (cond-f)
diff --git a/tools/trec.scm b/tools/trec.scm
index 901ff72..9fba9fd 100644
--- a/tools/trec.scm
+++ b/tools/trec.scm
@@ -5,8 +5,8 @@
       `(if (not ,test) (begin ,@body))))
 
 (define (fib n)
-  (if (< n 2)
-      n
+  (if (<= n 2)
+      1
       (+ (fib (- n 1))
          (fib (- n 2)))))
 
@@ -16,10 +16,10 @@
 
 
 (define (fibr n)
-  (if (>= n 2)
+  (if (> n 2)
       (+ (fibr (- n 1))
          (fibr (- n 2)))
-      n))
+      1))
 
 (let ((f32 (fibr 32)))
   (unless (= f32 2178309) ;3524578)
diff --git a/tools/tshoot.scm b/tools/tshoot.scm
index 84bfdf5..4c711d1 100644
--- a/tools/tshoot.scm
+++ b/tools/tshoot.scm
@@ -52,7 +52,7 @@
 
 ;; (fannkuch 7): (228 . 16), 8: (1616 . 22), 9: (8629 . 30), 10: (73196 . 38), 11: (556355 . 51), 12: (3968050 . 65)
 (display (fannkuch 7)) (newline)
-;; (fannkuch 12) takes around 5 minutes (297 secs)
+;(fannkuch 12) ;takes around 5 minutes (297 secs)
 
 ;;; --------------------------------------------------------------------------------
 
@@ -176,7 +176,7 @@
 		   (format *stderr* "~D~9Ttrees of depth ~D~30Tcheck: ~D~%" iterations depth check)))))
 	  (format *stderr* "long lived tree of depth ~D~30Tcheck: ~D~%" max-depth (item-check long-lived-tree)))))))
 
-;;(binary-tree 21) ; 20 secs
+;(binary-tree 21) ; 20 secs
 (binary-tree 6)
 
 ;;; stretch      tree of  depth 22	 check: 8388607
@@ -215,9 +215,9 @@
 	    (set! num i)))
 	(format *stderr* "Maximum stopping distance ~D, starting number ~D\n" len num)))))
 
-;(collatz 300000)
+;; (collatz 300000)
 ;; Maximum stopping distance 442, starting number 230631
-;; .6 secs
+;; .45 secs
 
 (collatz 20000)
 
@@ -241,7 +241,7 @@
 		 (set! L (cdr L))))))))
 
 (let ()
-  (define (count-primes limit)          ; for limit=10000000 12.3 secs 664579
+  (define (count-primes limit)          ; for limit=10000000 10.4 secs 664579
     (let ((primes 0))
       (do ((i 2 (+ i 1)))
 	  ((= i limit)
@@ -303,7 +303,7 @@
       
       (sqrt (/ vBv vV))))
 
-  (display (spectral-norm 125)) ; (spectral-norm 5500) takes about 19.4 secs
+  (display (spectral-norm 125)) ; (spectral-norm 5500) takes about 14.3 secs
   (newline))
 
 ;;; --------------------------------------------------------------------------------
diff --git a/tools/tvect.scm b/tools/tvect.scm
index 1c909eb..a9ae4f5 100644
--- a/tools/tvect.scm
+++ b/tools/tvect.scm
@@ -1,6 +1,6 @@
 ;;; vector timing tests
 
-(set! (*s7* 'heap-size) 1024000)
+(set! (*s7* 'heap-size) (* 2 1024000))
 
 (define size 300000)
 (define size/10 (/ size 10))
@@ -366,7 +366,7 @@
   (let ((v (make-vector size)))
     (do ((i 0 (+ i 1)))
 	((= i size) (vector-ref v 0))
-      (list-values (vector-set! v i 2)))))
+      (values (vector-set! v i 2)))))
 
 (unless (= (h7) 2)
   (format *stderr* "h7: ~S~%" (h7)))
@@ -452,7 +452,7 @@
 	((= k 10) (vector-ref v 0 0))
       (do ((i 0 (+ i 1)))
 	  ((= i size/10))
-	(list-values (vector-set! v k i 2))))))
+	(values (vector-set! v k i 2))))))
 
 (unless (= (h17) 2)
   (format *stderr* "h17: ~S~%" (h17)))
@@ -515,7 +515,7 @@
   (let ((v (make-vector size)))
     (do ((i 0 (+ i 1)))
 	((= i size) (v 0))
-      (list-values (set! (v i) 2)))))
+      (values (set! (v i) 2)))))
 
 (unless (= (j6) 2)
   (format *stderr* "j6: ~S~%" (j6)))
@@ -587,7 +587,7 @@
 	((= k 10) (v 0 0))
       (do ((i 0 (+ i 1)))
 	  ((= i size/10))
-	(list-values (set! (v k i) 2))))))
+	(values (set! (v k i) 2))))))
 
 (unless (= (j16) 2)
   (format *stderr* "j16: ~S~%" (j16)))
diff --git a/tools/valcall.scm b/tools/valcall.scm
index 58a1964..61de52c 100644
--- a/tools/valcall.scm
+++ b/tools/valcall.scm
@@ -79,25 +79,25 @@
 	 (list "repl" "tshoot.scm")
 	 (list "snd -noinit" "make-index.scm")
 	 (list "repl" "teq.scm")
-	 (list "repl" "s7test.scm")
 	 (list "repl" "tvect.scm")
-	 (list "repl" "tmisc.scm")
+	 (list "repl" "s7test.scm")
 	 (list "repl" "lt.scm")
 	 (list "repl" "tlet.scm")
 	 (list "repl" "tform.scm")
 	 (list "repl" "tcopy.scm")
 	 (list "repl" "tread.scm")
-	 (list "repl" "tclo.scm")
+	 (list "repl" "tmisc.scm")
 	 (list "repl" "tmat.scm")
+	 (list "repl" "dup.scm")
+	 (list "repl" "trclo.scm")
 	 (list "repl" "fbench.scm")
 	 (list "repl" "titer.scm")
-	 (list "repl" "trclo.scm")
 	 (list "repl" "tmap.scm")
 	 (list "repl" "tset.scm")
 	 (list "repl" "tsort.scm")
-	 (list "repl" "dup.scm")
 	 (list "repl" "tmac.scm")
 	 (list "repl" "tfft.scm")
+	 (list "repl" "tclo.scm")
 	 (list "repl" "trec.scm")
 	 (list "repl" "thash.scm")
 	 (list "snd -noinit" "tgen.scm")    ; repl here + cload sndlib was slower
diff --git a/tools/xgdata.scm b/tools/xgdata.scm
index 38e2e4c..7c0781a 100644
--- a/tools/xgdata.scm
+++ b/tools/xgdata.scm
@@ -3820,7 +3820,7 @@
 (CFNC "PangoAttribute* pango_attr_iterator_get PangoAttrIterator* iterator PangoAttrType type")
 (CFNC "void pango_attr_iterator_get_font PangoAttrIterator* iterator PangoFontDescription* desc PangoLanguage** [language] GSList** [extra_attrs]")
 (CFNC "gboolean pango_parse_markup char* markup_text int length gunichar accel_marker PangoAttrList** attr_list char** text gunichar* accel_char GError** [error]")
-(CFNC "void pango_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
+;;; 30-Oct-19 (CFNC "void pango_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
 (CFNC "void pango_find_paragraph_boundary gchar* text gint length gint* [paragraph_delimiter_index] gint* [next_paragraph_start]")
 (CFNC "void pango_get_log_attrs char* text int length int level PangoLanguage* language PangoLogAttr* log_attrs int attrs_len")
 ;(CFNC-extra "void pango_default_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
@@ -3851,9 +3851,9 @@
 (CFNC "PangoCoverage* pango_coverage_copy PangoCoverage* coverage")
 (CFNC "PangoCoverageLevel pango_coverage_get PangoCoverage* coverage int index")
 (CFNC "void pango_coverage_set PangoCoverage* coverage int index PangoCoverageLevel level")
-(CFNC "void pango_coverage_max PangoCoverage* coverage PangoCoverage* other")
-(CFNC "void pango_coverage_to_bytes PangoCoverage* coverage guchar** [bytes] int* [n_bytes]") ; FREE (bytes)
-(CFNC "PangoCoverage* pango_coverage_from_bytes guchar* bytes int n_bytes") ; FREE
+;;; 30-Oct-19 (CFNC "void pango_coverage_max PangoCoverage* coverage PangoCoverage* other")
+;;; 30-Oct-19 (CFNC "void pango_coverage_to_bytes PangoCoverage* coverage guchar** [bytes] int* [n_bytes]") ; FREE (bytes)
+;;; 30-Oct-19 (CFNC "PangoCoverage* pango_coverage_from_bytes guchar* bytes int n_bytes") ; FREE
 ;(CSTR-extra "PANGO_ENGINE_TYPE_LANG")
 ;(CSTR-extra "PANGO_ENGINE_TYPE_SHAPE")
 ;(CSTR-extra "PANGO_RENDER_TYPE_NONE")
@@ -5174,7 +5174,7 @@
 ;;;(CFNC "void pango_matrix_scale PangoMatrix* matrix double scale_x double scale_y")
 ;;;(CFNC "void pango_matrix_rotate PangoMatrix* matrix double degrees")
 ;;;(CFNC "void pango_matrix_concat PangoMatrix* matrix PangoMatrix* new_matrix")
-(CFNC "PangoScript pango_script_for_unichar gunichar ch")
+;;; 30-Oct-19 (CFNC "PangoScript pango_script_for_unichar gunichar ch")
 (CFNC "PangoScriptIter* pango_script_iter_new char* text int length")
 (CFNC "void pango_script_iter_get_range PangoScriptIter* iter char** [start] char** [end] PangoScript* [script]" 'const)
 (CFNC "gboolean pango_script_iter_next PangoScriptIter* iter")