some corrections/removals of old tests
svn: r16680
This commit is contained in:
Matthew Flatt
parent
f2d14f7af0
commit
1d64270f5d
|
|
@ -52,8 +52,8 @@
|
|||
(test #t char-set-contains? char-set:letter+digit #\A)
|
||||
(test #t char-set-contains? char-set:letter+digit #\Z)
|
||||
|
||||
;; As of Unicode 4.1:
|
||||
(test 91395 char-set-size char-set:letter)
|
||||
;; As of Unicode 5.0:
|
||||
(test 93217 char-set-size char-set:letter)
|
||||
|
||||
(test #t char-set= char-set:letter+digit (char-set-union char-set:letter char-set:digit))
|
||||
;; Slow!:
|
||||
|
|
@ -109,9 +109,8 @@
|
|||
|
||||
;; Iterating over character sets ----------------------------------------
|
||||
|
||||
;; The number 270 comes from "grep Nd UnicodeData.txt | wc -l"
|
||||
;; in Unicode 4.1
|
||||
(test 270 char-set-size char-set:digit)
|
||||
;; As of Unicode 5.0
|
||||
(test 388 char-set-size char-set:digit)
|
||||
|
||||
(test #t char-set=
|
||||
char-set:digit
|
||||
|
|
|
|||
|
|
@ -3,11 +3,11 @@
|
|||
;; printouts.
|
||||
|
||||
(module helpers mzscheme
|
||||
(require mzlib/package)
|
||||
(require scheme/package)
|
||||
|
||||
(provide identifier-syntax with-implicit
|
||||
(rename package module)
|
||||
(rename open import))
|
||||
(rename define-package module)
|
||||
(rename open-package import))
|
||||
|
||||
(define-syntax (identifier-syntax stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -25,8 +25,8 @@
|
|||
body)])))
|
||||
|
||||
|
||||
(require helpers)
|
||||
(require-for-syntax helpers)
|
||||
(require 'helpers)
|
||||
(require (for-syntax 'helpers))
|
||||
|
||||
;; Make evaluation print the result, for testing
|
||||
(let ([eh (current-eval)])
|
||||
|
|
@ -36,8 +36,6 @@
|
|||
(printf "~s~n" v))
|
||||
v))))
|
||||
|
||||
(read-case-sensitive #t)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; From "Extending the Scope of Syntactic Abstraction"
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -49,7 +47,7 @@
|
|||
(define z 5))
|
||||
(let ((y x) (z 0))
|
||||
(import M)
|
||||
(setter 3)
|
||||
(setter 3)
|
||||
(list x y z)))
|
||||
"(3 1 0) is correct"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,28 +0,0 @@
|
|||
|
||||
(require-library "mzlib.ss")
|
||||
|
||||
(define actual-definitions
|
||||
(filter (lambda (s)
|
||||
(let ([s (symbol->string s)])
|
||||
(not (char=? (string-ref s 0) #\#))))
|
||||
(map car (make-global-value-list))))
|
||||
|
||||
(define doc-path (collection-path "doc"))
|
||||
|
||||
(define r5rs-keywords (with-input-from-file (build-path doc-path "r5rs" "keywords") read))
|
||||
(define mzscheme-keywords (with-input-from-file (build-path doc-path "mzscheme" "keywords") read))
|
||||
|
||||
(define documented
|
||||
(map string->symbol (map car (append r5rs-keywords mzscheme-keywords))))
|
||||
|
||||
(for-each
|
||||
(lambda (doc)
|
||||
(unless (memq doc actual-definitions)
|
||||
(printf "Documented but doesn't exist: ~a~n" doc)))
|
||||
documented)
|
||||
|
||||
(for-each
|
||||
(lambda (act)
|
||||
(unless (memq act documented)
|
||||
(printf "Undocumented: ~a~n" act)))
|
||||
actual-definitions)
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
|
||||
(require-library "compat.ss")
|
||||
(require-library "compat.ss")
|
||||
(require-library "compat.ss")
|
||||
|
||||
(defmacro test (x y) (string-append x y))
|
||||
|
||||
(test "a" "b")
|
||||
|
||||
(load x)
|
||||
(require-library)
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
|
||||
; Tests simple compilation by setting the eval handler and
|
||||
; running all tests
|
||||
|
||||
(let ([orig (current-eval)])
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(current-eval
|
||||
(lambda (x)
|
||||
(orig (compile x)))))
|
||||
(lambda ()
|
||||
(load "all.ss"))
|
||||
(lambda ()
|
||||
(current-eval orig))))
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
|
||||
(define teach-dir (build-path (collection-path "lang") "private"))
|
||||
(define compiled-file (build-path teach-dir "compiled" "teach.zo"))
|
||||
(define saved-file (string-append compiled-file ".save"))
|
||||
|
||||
(define compiled? (file-exists? compiled-file))
|
||||
(when compiled?
|
||||
(rename-file-or-directory compiled-file saved-file))
|
||||
|
||||
(require errortrace)
|
||||
|
||||
(execute-counts-enabled #t)
|
||||
(dynamic-require 'lang/private/teach #f)
|
||||
(execute-counts-enabled #f)
|
||||
|
||||
(when compiled?
|
||||
(rename-file-or-directory saved-file compiled-file))
|
||||
|
||||
(load "beginner.ss")
|
||||
(require mzscheme)
|
||||
(load "beginner-abbr.ss")
|
||||
(require mzscheme)
|
||||
(load "intermediate.ss")
|
||||
(require mzscheme)
|
||||
(load "advanced.ss")
|
||||
(require mzscheme)
|
||||
|
||||
(with-output-to-file "teach-annotated.ss"
|
||||
(lambda ()
|
||||
(annotate-executed-file (build-path (collection-path "lang") "private" "teach.ss")))
|
||||
'truncate/replace)
|
||||
|
||||
|
|
@ -1,467 +0,0 @@
|
|||
;;; -*- scheme -*-
|
||||
;;; Fortran-style implementation of an EM clustering algorithm.
|
||||
;;;
|
||||
;;; Written by Jeffrey Mark Siskind (qobi@cs.toronto.edu)
|
||||
;;; R4RS-ified by by Lars Thomas Hansen (lth@cs.uoregon.edu)
|
||||
;;; Random number generator by Ozan Yigit.
|
||||
;;;
|
||||
;;; To run: (run-benchmark)
|
||||
;;; You must provide your own timer function.
|
||||
;;;
|
||||
;;; Some benchmark times:
|
||||
;;;
|
||||
;;; Chez Scheme 4.1 for SunOS running on Sparc 10/51 (1MB,96MB,50MHz), Solaris:
|
||||
;;; Optimize-level 2: 112s run (CPU), 2.8s gc, 326 MB allocated, 1181 GCs
|
||||
;;; Optimize-level 3: 79s run (CPU), 2.8s gc, 326 MB allocated, 1163 GCs
|
||||
|
||||
(define make-model vector)
|
||||
(define (model-pi model) (vector-ref model 0))
|
||||
(define (set-model-pi! model x) (vector-set! model 0 x))
|
||||
(define (model-mu model) (vector-ref model 1))
|
||||
(define (model-sigma model) (vector-ref model 2))
|
||||
(define (model-log-pi model) (vector-ref model 3))
|
||||
(define (set-model-log-pi! model x) (vector-set! model 3 x))
|
||||
(define (model-sigma-inverse model) (vector-ref model 4))
|
||||
(define (model-log-determinant-sigma model) (vector-ref model 5))
|
||||
(define (set-model-log-sigma-determinant! model x) (vector-set! model 5 x))
|
||||
|
||||
;---------------------------------------------------------------------------
|
||||
; Minimal Standard Random Number Generator
|
||||
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
|
||||
; better constants, as proposed by Park.
|
||||
; By Ozan Yigit
|
||||
|
||||
(define *seed* 1)
|
||||
|
||||
(define (srand seed)
|
||||
(set! *seed* seed)
|
||||
*seed*)
|
||||
|
||||
(define (rand)
|
||||
(let ((A 48271)
|
||||
(M 2147483647)
|
||||
(Q 44488)
|
||||
(R 3399))
|
||||
(let* ((hi (quotient *seed* Q))
|
||||
(lo (modulo *seed* Q))
|
||||
(test (- (* A lo) (* R hi))))
|
||||
(if (> test 0)
|
||||
(set! *seed* test)
|
||||
(set! *seed* (+ test M)))))
|
||||
*seed*)
|
||||
|
||||
;---------------------------------------------------------------------------
|
||||
|
||||
(define (panic s) (error 'panic s))
|
||||
|
||||
(define *rand-max* 2147483648)
|
||||
|
||||
(define log-math-precision 35.0)
|
||||
|
||||
(define minus-infinity (- *rand-max*))
|
||||
|
||||
(define first car)
|
||||
|
||||
(define second cadr)
|
||||
|
||||
(define rest cdr)
|
||||
|
||||
(define (reduce f l i)
|
||||
(cond ((null? l) i)
|
||||
((null? (rest l)) (first l))
|
||||
(else (let loop ((l (rest l)) (c (first l)))
|
||||
(if (null? l) c (loop (rest l) (f c (first l))))))))
|
||||
|
||||
(define (every-n p n)
|
||||
(let loop ((i 0)) (or (>= i n) (and (p i) (loop (+ i 1))))))
|
||||
|
||||
(define (sum f n)
|
||||
(let loop ((n (- n 1)) (c 0.0))
|
||||
(if (negative? n) c (loop (- n 1) (+ c (f n))))))
|
||||
|
||||
(define (add-exp e1 e2)
|
||||
(let* ((e-max (max e1 e2))
|
||||
(e-min (min e1 e2))
|
||||
(factor (floor e-min)))
|
||||
(if (= e-max minus-infinity)
|
||||
minus-infinity
|
||||
(if (> (- e-max factor) log-math-precision)
|
||||
e-max
|
||||
(+ (log (+ (exp (- e-max factor)) (exp (- e-min factor))))
|
||||
factor)))))
|
||||
|
||||
(define (map-n f n)
|
||||
(let loop ((i 0) (c '()))
|
||||
(if (< i n) (loop (+ i 1) (cons (f i) c)) (reverse c))))
|
||||
|
||||
(define (map-n-vector f n)
|
||||
(let ((v (make-vector n)))
|
||||
(let loop ((i 0))
|
||||
(if (< i n)
|
||||
(begin (vector-set! v i (f i))
|
||||
(loop (+ i 1)))))
|
||||
v))
|
||||
|
||||
(define (remove-if-not p l)
|
||||
(let loop ((l l) (c '()))
|
||||
(cond ((null? l) (reverse c))
|
||||
((p (first l)) (loop (rest l) (cons (first l) c)))
|
||||
(else (loop (rest l) c)))))
|
||||
|
||||
(define (positionv x l)
|
||||
(let loop ((l l) (i 0))
|
||||
(cond ((null? l) #f)
|
||||
((eqv? x (first l)) i)
|
||||
(else (loop (rest l) (+ i 1))))))
|
||||
|
||||
(define (make-matrix m n)
|
||||
(map-n-vector (lambda (i) (make-vector n)) m))
|
||||
|
||||
(define (make-matrix-initial m n initial)
|
||||
(map-n-vector (lambda (i) (make-vector n initial)) m))
|
||||
|
||||
(define (matrix-rows a) (vector-length a))
|
||||
|
||||
(define (matrix-columns a) (vector-length (vector-ref a 0)))
|
||||
|
||||
(define (matrix-ref a i j) (vector-ref (vector-ref a i) j))
|
||||
|
||||
(define (matrix-set! a i j x) (vector-set! (vector-ref a i) j x))
|
||||
|
||||
(define (matrix-row-ref a i) (vector-ref a i))
|
||||
|
||||
(define (matrix-row-set! a i v) (vector-set! a i v))
|
||||
|
||||
(define (determinant a)
|
||||
(if (not (= (matrix-rows a) (matrix-columns a)))
|
||||
(panic "Can only find determinant of a square matrix"))
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(let* ((n (matrix-rows a))
|
||||
(b (make-matrix n n))
|
||||
(d 1.0))
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
(do ((j 0 (+ j 1))) ((= j n)) (matrix-set! b i j (matrix-ref a i j))))
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
;; partial pivoting reduces rounding errors
|
||||
(let ((greatest (abs (matrix-ref b i i)))
|
||||
(index i))
|
||||
(do ((j (+ i 1) (+ j 1))) ((= j n))
|
||||
(let ((x (abs (matrix-ref b j i))))
|
||||
(if (> x greatest) (begin (set! index j) (set! greatest x)))))
|
||||
(if (= greatest 0.0) (return 0.0))
|
||||
(if (not (= index i))
|
||||
(let ((v (matrix-row-ref b i)))
|
||||
(matrix-row-set! b i (matrix-row-ref b index))
|
||||
(matrix-row-set! b index v)
|
||||
(set! d (- d))))
|
||||
(let ((c (matrix-ref b i i)))
|
||||
(set! d (* d c))
|
||||
(do ((j i (+ j 1))) ((= j n))
|
||||
(matrix-set! b i j (/ (matrix-ref b i j) c)))
|
||||
(do ((j (+ i 1) (+ j 1))) ((= j n))
|
||||
(let ((e (matrix-ref b j i)))
|
||||
(do ((k (+ i 1) (+ k 1))) ((= k n))
|
||||
(matrix-set!
|
||||
b j k (- (matrix-ref b j k) (* e (matrix-ref b i k))))))))))
|
||||
d))))
|
||||
|
||||
(define (invert-matrix! a b)
|
||||
(if (not (= (matrix-rows a) (matrix-columns a)))
|
||||
(panic "Can only invert a square matrix"))
|
||||
(let* ((n (matrix-rows a))
|
||||
(c (make-matrix n n)))
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(matrix-set! b i j 0.0)
|
||||
(matrix-set! c i j (matrix-ref a i j))))
|
||||
(do ((i 0 (+ i 1))) ((= i n)) (matrix-set! b i i 1.0))
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
(if (zero? (matrix-ref c i i))
|
||||
(call-with-current-continuation
|
||||
(lambda (return)
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(if (and (> j i) (not (zero? (matrix-ref c j i))))
|
||||
(begin
|
||||
(let ((e (vector-ref c i)))
|
||||
(vector-set! c i (vector-ref c j))
|
||||
(vector-set! c j e))
|
||||
(let ((e (vector-ref b i)))
|
||||
(vector-set! b i (vector-ref b j))
|
||||
(vector-set! b j e))
|
||||
(return #f))))
|
||||
(panic "Matrix is singular"))))
|
||||
(let ((d (/ (matrix-ref c i i))))
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(matrix-set! c i j (* d (matrix-ref c i j)))
|
||||
(matrix-set! b i j (* d (matrix-ref b i j))))
|
||||
(do ((k 0 (+ k 1))) ((= k n))
|
||||
(let ((d (- (matrix-ref c k i))))
|
||||
(if (not (= k i))
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(matrix-set!
|
||||
c k j (+ (matrix-ref c k j) (* d (matrix-ref c i j))))
|
||||
(matrix-set!
|
||||
b k j (+ (matrix-ref b k j) (* d (matrix-ref b i j))))))))))))
|
||||
|
||||
(define (jacobi! a)
|
||||
(if (not (and (= (matrix-rows a) (matrix-columns a))
|
||||
(every-n (lambda (i)
|
||||
(every-n (lambda (j)
|
||||
(= (matrix-ref a i j) (matrix-ref a j i)))
|
||||
(matrix-rows a)))
|
||||
(matrix-rows a))))
|
||||
(panic "Can only compute eigenvalues/eigenvectors of a symmetric matrix"))
|
||||
(let* ((n (matrix-rows a))
|
||||
(d (make-vector n))
|
||||
(v (make-matrix-initial n n 0.0))
|
||||
(b (make-vector n))
|
||||
(z (make-vector n 0.0)))
|
||||
(do ((ip 0 (+ ip 1))) ((= ip n))
|
||||
(matrix-set! v ip ip 1.0)
|
||||
(vector-set! b ip (matrix-ref a ip ip))
|
||||
(vector-set! d ip (matrix-ref a ip ip)))
|
||||
(let loop ((i 0))
|
||||
(if (> i 50) (panic "Too many iterations in JACOBI!"))
|
||||
(let ((sm (sum (lambda (ip)
|
||||
(sum (lambda (ir)
|
||||
(let ((iq (+ ip ir 1)))
|
||||
(abs (matrix-ref a ip iq))))
|
||||
(- n ip 1)))
|
||||
(- n 1))))
|
||||
(if (not (zero? sm))
|
||||
(begin
|
||||
(let ((tresh (if (< i 3) (/ (* 0.2 sm) (* n n)) 0.0)))
|
||||
(do ((ip 0 (+ ip 1))) ((= ip (- n 1)))
|
||||
(do ((ir 0 (+ ir 1))) ((= ir (- n ip 1)))
|
||||
(let* ((iq (+ ip ir 1))
|
||||
(g (* 100.0 (abs (matrix-ref a ip iq)))))
|
||||
(cond
|
||||
((and (> i 3)
|
||||
(= (+ (abs (vector-ref d ip)) g)
|
||||
(abs (vector-ref d ip)))
|
||||
(= (+ (abs (vector-ref d iq)) g)
|
||||
(abs (vector-ref d iq))))
|
||||
(matrix-set! a ip iq 0.0))
|
||||
((> (abs (matrix-ref a ip iq)) tresh)
|
||||
(let* ((h (- (vector-ref d iq) (vector-ref d ip)))
|
||||
(t (if (= (+ (abs h) g) (abs h))
|
||||
(/ (matrix-ref a ip iq) h)
|
||||
(let ((theta (/ (* 0.5 h)
|
||||
(matrix-ref a ip iq))))
|
||||
(if (negative? theta)
|
||||
(- (/ (+ (abs theta)
|
||||
(sqrt (+ (* theta theta) 1.0)))))
|
||||
(/ (+ (abs theta)
|
||||
(sqrt (+ (* theta theta) 1.0))))))))
|
||||
(c (/ (sqrt (+ (* t t) 1.0))))
|
||||
(s (* t c))
|
||||
(tau (/ s (+ c 1.0)))
|
||||
(h (* t (matrix-ref a ip iq))))
|
||||
(define (rotate a i j k l)
|
||||
(let ((g (matrix-ref a i j))
|
||||
(h (matrix-ref a k l)))
|
||||
(matrix-set! a i j (- g (* s (+ h (* g tau)))))
|
||||
(matrix-set! a k l (+ h (* s (- g (* h tau)))))))
|
||||
(vector-set! z ip (- (vector-ref z ip) h))
|
||||
(vector-set! z iq (+ (vector-ref z iq) h))
|
||||
(vector-set! d ip (- (vector-ref d ip) h))
|
||||
(vector-set! d iq (+ (vector-ref d iq) h))
|
||||
(matrix-set! a ip iq 0.0)
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(cond ((< j ip) (rotate a j ip j iq))
|
||||
((< ip j iq) (rotate a ip j j iq))
|
||||
((< iq j) (rotate a ip j iq j)))
|
||||
(rotate v j ip j iq)))))))))
|
||||
(do ((ip 0 (+ ip 1))) ((= ip n))
|
||||
(vector-set! b ip (+ (vector-ref b ip) (vector-ref z ip)))
|
||||
(vector-set! d ip (vector-ref b ip))
|
||||
(vector-set! z ip 0.0))
|
||||
(loop (+ i 1))))))
|
||||
(do ((i 0 (+ i 1))) ((= i (- n 1)))
|
||||
(let ((k i)
|
||||
(p (vector-ref d i)))
|
||||
(do ((l 0 (+ l 1))) ((= l (- n i 1)))
|
||||
(let* ((j (+ i l 1)))
|
||||
(if (>= (vector-ref d j) p)
|
||||
(begin (set! k j) (set! p (vector-ref d j))))))
|
||||
(if (not (= k i))
|
||||
(begin (vector-set! d k (vector-ref d i))
|
||||
(vector-set! d i p)
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(let ((p (matrix-ref v j i)))
|
||||
(matrix-set! v j i (matrix-ref v j k))
|
||||
(matrix-set! v j k p)))))))
|
||||
(list d v)))
|
||||
|
||||
(define (clip-eigenvalues! a v)
|
||||
(let* ((j (jacobi! a))
|
||||
(l (first j))
|
||||
(e (second j)))
|
||||
(do ((k1 0 (+ k1 1))) ((= k1 (vector-length a)))
|
||||
(let ((a-k1 (vector-ref a k1))
|
||||
(e-k1 (vector-ref e k1)))
|
||||
(do ((k2 0 (+ k2 1))) ((= k2 (vector-length a-k1)))
|
||||
(let ((e-k2 (vector-ref e k2))
|
||||
(s 0.0))
|
||||
(do ((k 0 (+ k 1))) ((= k (vector-length a)))
|
||||
(set! s (+ s (* (max (vector-ref v k) (vector-ref l k))
|
||||
(vector-ref e-k1 k)
|
||||
(vector-ref e-k2 k)))))
|
||||
(vector-set! a-k1 k2 s)))))))
|
||||
|
||||
;;; EM
|
||||
|
||||
(define (e-step! x z models)
|
||||
(do ((i 0 (+ i 1))) ((= i (vector-length x)))
|
||||
(let ((xi (vector-ref x i))
|
||||
(zi (vector-ref z i)))
|
||||
(do ((j 0 (+ j 1))) ((= j (vector-length models)))
|
||||
;; Compute for each model.
|
||||
(let* ((model (vector-ref models j))
|
||||
(log-pi (model-log-pi model))
|
||||
(mu (model-mu model))
|
||||
(sigma-inverse (model-sigma-inverse model))
|
||||
(log-determinant-sigma (model-log-determinant-sigma model))
|
||||
(t 0.0))
|
||||
;; Compute likelihoods (note: up to constant for all models).
|
||||
(set! t 0.0)
|
||||
(do ((k1 0 (+ k1 1))) ((= k1 (vector-length xi)))
|
||||
(let ((sigma-inverse-k1 (vector-ref sigma-inverse k1)))
|
||||
(do ((k2 0 (+ k2 1))) ((= k2 (vector-length xi)))
|
||||
(set! t (+ t (* (- (vector-ref xi k1) (vector-ref mu k1))
|
||||
(vector-ref sigma-inverse-k1 k2)
|
||||
(- (vector-ref xi k2) (vector-ref mu k2))))))))
|
||||
(vector-set! zi j (- log-pi (* 0.5 (+ log-determinant-sigma t))))))))
|
||||
(let ((l 0.0))
|
||||
(do ((i 0 (+ i 1))) ((= i (vector-length x)))
|
||||
(let ((s minus-infinity)
|
||||
(zi (vector-ref z i)))
|
||||
;; Normalize ownerships to sum to one.
|
||||
(do ((j 0 (+ j 1))) ((= j (vector-length models)))
|
||||
(set! s (add-exp s (vector-ref zi j))))
|
||||
(do ((j 0 (+ j 1))) ((= j (vector-length models)))
|
||||
(vector-set! zi j (exp (- (vector-ref zi j) s))))
|
||||
(set! l (+ l s))))
|
||||
;; Return log likelihood.
|
||||
l))
|
||||
|
||||
(define (m-step! x models z clip)
|
||||
(let ((kk (vector-length (vector-ref x 0))))
|
||||
;; For each model, optimize parameters.
|
||||
(do ((j 0 (+ j 1))) ((= j (vector-length models)))
|
||||
(let* ((model (vector-ref models j))
|
||||
(mu (model-mu model))
|
||||
(sigma (model-sigma model))
|
||||
(s 0.0))
|
||||
;; Optimize values.
|
||||
(do ((k 0 (+ k 1))) ((= k kk))
|
||||
(do ((i 0 (+ i 1))) ((= i (vector-length x)))
|
||||
(set! s (+ s (vector-ref (vector-ref z i) j)))))
|
||||
(do ((k 0 (+ k 1))) ((= k kk))
|
||||
(let ((m 0.0))
|
||||
(do ((i 0 (+ i 1))) ((= i (vector-length x)))
|
||||
(set! m (+ m (* (vector-ref (vector-ref z i) j)
|
||||
(vector-ref (vector-ref x i) k)))))
|
||||
(vector-set! mu k (/ m s))))
|
||||
(do ((k1 0 (+ k1 1))) ((= k1 kk))
|
||||
(let ((sigma-k1 (vector-ref sigma k1))
|
||||
(mu-k1 (vector-ref mu k1)))
|
||||
(do ((k2 0 (+ k2 1))) ((= k2 kk))
|
||||
(let ((mu-k2 (vector-ref mu k2))
|
||||
(m 0.0))
|
||||
(do ((i 0 (+ i 1))) ((= i (vector-length x)))
|
||||
(set! m (+ m (* (vector-ref (vector-ref z i) j)
|
||||
(- (vector-ref (vector-ref x i) k1) mu-k1)
|
||||
(- (vector-ref (vector-ref x i) k2) mu-k2)))))
|
||||
(vector-set! sigma-k1 k2 (/ m s))))))
|
||||
(clip-eigenvalues! sigma clip)
|
||||
(set-model-pi! model (/ s (vector-length x)))
|
||||
(set-model-log-pi! model (log (/ s (vector-length x))))
|
||||
(invert-matrix! sigma (model-sigma-inverse model))
|
||||
(set-model-log-sigma-determinant! model (log (determinant sigma)))))))
|
||||
|
||||
(define (em! x z models clip em-kick-off-tolerance em-convergence-tolerance)
|
||||
(let loop ((old-log-likelihood minus-infinity) (starting? #t))
|
||||
(let ((log-likelihood (e-step! x z models)))
|
||||
(cond
|
||||
((or (and starting? (> log-likelihood old-log-likelihood))
|
||||
(> log-likelihood (+ old-log-likelihood em-convergence-tolerance)))
|
||||
(m-step! x models z clip)
|
||||
(loop log-likelihood
|
||||
(and starting?
|
||||
(not (= (vector-length models) 1))
|
||||
(or (= old-log-likelihood minus-infinity)
|
||||
(< log-likelihood
|
||||
(+ old-log-likelihood em-kick-off-tolerance))))))
|
||||
(else old-log-likelihood)))))
|
||||
|
||||
(define (noise epsilon) (- (* 2.0 epsilon (/ (rand) *rand-max*)) epsilon))
|
||||
|
||||
(define (initial-z ii jj)
|
||||
(map-n-vector
|
||||
(lambda (i)
|
||||
(let ((zi (map-n-vector (lambda (j) (+ (/ jj) (noise (/ jj)))) jj))
|
||||
(s 0.0))
|
||||
(do ((j 0 (+ j 1))) ((= j jj)) (set! s (+ s (vector-ref zi j))))
|
||||
(do ((j 0 (+ j 1))) ((= j jj)) (vector-set! zi j (/ (vector-ref zi j) s)))
|
||||
zi))
|
||||
ii))
|
||||
|
||||
(define (ems x clip em-kick-off-tolerance em-convergence-tolerance
|
||||
ems-convergence-tolerance)
|
||||
(let loop ((jj 1)
|
||||
(old-z #f)
|
||||
(old-models #f)
|
||||
(old-log-likelihood minus-infinity))
|
||||
(let* ((kk (vector-length (vector-ref x 0)))
|
||||
(z (initial-z (vector-length x) jj))
|
||||
(models (map-n-vector
|
||||
(lambda (j)
|
||||
(make-model 0.0
|
||||
(make-vector kk)
|
||||
(make-matrix kk kk)
|
||||
0.0
|
||||
(make-matrix kk kk)
|
||||
0.0))
|
||||
jj)))
|
||||
(m-step! x models z clip)
|
||||
(let ((new-log-likelihood
|
||||
(em!
|
||||
x z models clip em-kick-off-tolerance em-convergence-tolerance)))
|
||||
(if (> (- (/ old-log-likelihood new-log-likelihood) 1.0)
|
||||
ems-convergence-tolerance)
|
||||
(loop (+ jj 1) z models new-log-likelihood)
|
||||
(list old-z old-models))))))
|
||||
|
||||
(define (em-clusterer x clip em-kick-off-tolerance em-convergence-tolerance
|
||||
ems-convergence-tolerance)
|
||||
(let* ((z-models (ems x clip em-kick-off-tolerance
|
||||
em-convergence-tolerance
|
||||
ems-convergence-tolerance))
|
||||
(z (first z-models))
|
||||
(models (second z-models)))
|
||||
(e-step! x z models)
|
||||
(let ((clusters
|
||||
(map-n (lambda (i)
|
||||
(let ((zi (vector->list (vector-ref z i))))
|
||||
(list i (positionv (reduce max zi minus-infinity) zi))))
|
||||
(vector-length z))))
|
||||
(map-n (lambda (j)
|
||||
(map (lambda (cluster) (vector-ref x (first cluster)))
|
||||
(remove-if-not (lambda (cluster) (= (second cluster) j))
|
||||
clusters)))
|
||||
(vector-length (vector-ref z 0))))))
|
||||
|
||||
(define (go)
|
||||
(em-clusterer
|
||||
'#(#(1.0) #(2.0) #(3.0) #(11.0) #(12.0) #(13.0)) '#(1.0) 10.0 1.0 0.01))
|
||||
|
||||
(define (run-benchmark)
|
||||
(srand 1)
|
||||
(do ((i 0 (+ i 1))) ((= i 100))
|
||||
(write (go))
|
||||
(newline)))
|
||||
|
||||
; eof
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
|
||||
; Tests image saving/loading by dumping an image
|
||||
; and loading it with every report-errs
|
||||
|
||||
(define dump/restore
|
||||
(lambda ()
|
||||
(printf "Dumping image...~n")
|
||||
(let ([result (write-image-to-file "tmp9")])
|
||||
(if (vector? result)
|
||||
(printf "Continuing ~a~n" result)
|
||||
(read-image-from-file "tmp9" #("after" "restore"))))))
|
||||
|
||||
(define ll null)
|
||||
(define load-relative
|
||||
(lambda (f)
|
||||
(set! ll (append ll (list f)))))
|
||||
|
||||
(#%load-relative "all.ss")
|
||||
|
||||
(define load-relative #%load-relative)
|
||||
|
||||
(define go
|
||||
(let ([d (current-load-relative-directory)])
|
||||
(lambda ()
|
||||
(parameterize ([current-load-relative-directory d])
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(load-relative f)
|
||||
(dump/restore))
|
||||
ll)))))
|
||||
|
||||
(printf "Run `(go)'~n")
|
||||
|
|
@ -1,70 +0,0 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(when (file-exists? "tmp-pipe")
|
||||
(delete-file "tmp-pipe"))
|
||||
|
||||
(require mzlib/process)
|
||||
(system "mknod tmp-pipe p")
|
||||
|
||||
(define i1 (open-input-file "tmp-pipe"))
|
||||
(define i2 (open-input-file "tmp-pipe"))
|
||||
(define o (open-output-file "tmp-pipe" 'append))
|
||||
|
||||
(let ([t (thread
|
||||
(lambda ()
|
||||
(with-handlers ([exn:break? void])
|
||||
(parameterize-break #f
|
||||
(read-bytes-avail!/enable-break (make-bytes 2) i1)))))])
|
||||
(sleep 0.1)
|
||||
(break-thread t)
|
||||
(sleep 0.1)
|
||||
(test #f thread-running? t))
|
||||
|
||||
;; Reading from i1 will pull in all ready chars
|
||||
(define (test-buffered i1 i2)
|
||||
(test #"he" read-bytes 2 i1)
|
||||
(test #f char-ready? i2)
|
||||
(test #"ll" read-bytes 2 i1)
|
||||
(test #"o\n" read-bytes 2 i1)
|
||||
(test #f char-ready? i1)
|
||||
(test #f char-ready? i2))
|
||||
|
||||
(display "hello\n" o)
|
||||
(test-buffered i1 i2)
|
||||
(display "hello\n" o)
|
||||
(test-buffered i2 i1)
|
||||
|
||||
(close-output-port o)
|
||||
(test eof read-byte i1)
|
||||
(test eof read-byte i2)
|
||||
(close-input-port i1)
|
||||
(close-input-port i2)
|
||||
|
||||
(define i1 (open-input-file "tmp-pipe"))
|
||||
(define i2 (open-input-file "tmp-pipe"))
|
||||
(define o (open-output-file "tmp-pipe" 'append))
|
||||
|
||||
(test 'block file-stream-buffer-mode i1)
|
||||
(test 'block file-stream-buffer-mode i2)
|
||||
(test (void) file-stream-buffer-mode i1 'none)
|
||||
(test (void) file-stream-buffer-mode i2 'none)
|
||||
|
||||
(define (test-unbuffered i1 i2)
|
||||
(let ([s (make-bytes 10)])
|
||||
(test 1 peek-bytes-avail! s 0 #f i1)
|
||||
(test 1 peek-bytes-avail! s 0 #f i1))
|
||||
(test #"he" read-bytes 2 i1)
|
||||
(test #t char-ready? i2)
|
||||
(test #"ll" read-bytes 2 i2)
|
||||
(test #"o\n" read-bytes 2 i1)
|
||||
(test #f char-ready? i1)
|
||||
(test #f char-ready? i2))
|
||||
|
||||
(display "hello\n" o)
|
||||
(test-unbuffered i1 i2)
|
||||
(display "hello\n" o)
|
||||
(test-unbuffered i2 i1)
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
|
||||
(if (not (defined? 'Section))
|
||||
(load-relative "testing.ss"))
|
||||
|
||||
(Section 'mzlib-threads)
|
||||
|
||||
(require-library "thread.ss")
|
||||
|
||||
(define sema (make-semaphore))
|
||||
(define sema2 (make-semaphore))
|
||||
(define c-out 0)
|
||||
(define SLEEP-TIME 0.1)
|
||||
|
||||
;;; consumer-thread ;;;
|
||||
|
||||
(define-values (th g) (consumer-thread (case-lambda
|
||||
[(f arg) (set! c-out (f arg))
|
||||
(semaphore-post sema)]
|
||||
[(f arg1 arg2) (set! c-out (f arg1 arg2))
|
||||
(semaphore-post sema)])))
|
||||
(g + 1 2)
|
||||
(semaphore-wait sema)
|
||||
(test 3 'consumer-thread c-out)
|
||||
|
||||
; queue 2
|
||||
(g car '(4 5))
|
||||
(g semaphore-wait sema2)
|
||||
(semaphore-wait sema)
|
||||
(test 4 'consumer-thread c-out)
|
||||
(semaphore-post sema2)
|
||||
(semaphore-wait sema)
|
||||
(test (void) 'consumer-thread c-out)
|
||||
|
||||
; queue 3
|
||||
(g / 2)
|
||||
(g semaphore-wait sema2)
|
||||
(g (lambda (s) (semaphore-wait s) 5) sema2)
|
||||
(semaphore-wait sema)
|
||||
(test 1/2 'consumer-thread c-out)
|
||||
(semaphore-post sema2)
|
||||
(semaphore-wait sema)
|
||||
(test (void) 'consumer-thread c-out)
|
||||
(semaphore-post sema2)
|
||||
(semaphore-wait sema)
|
||||
(test 5 'consumer-thread c-out)
|
||||
|
||||
; kill the consumer
|
||||
(kill-thread th)
|
||||
(g - 7)
|
||||
(sleep SLEEP-TIME)
|
||||
(test 5 'consumer-thread c-out)
|
||||
|
||||
(arity-test consumer-thread 1 2)
|
||||
(error-test '(consumer-thread 9))
|
||||
(arity-test g 2 3)
|
||||
|
||||
;;; semaphore-wait-multiple ;;;
|
||||
|
||||
(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
|
||||
(semaphore-post sema)
|
||||
(test sema semaphore-wait-multiple (list sema sema2))
|
||||
(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
|
||||
(semaphore-post sema2)
|
||||
(test sema2 semaphore-wait-multiple (list sema sema2))
|
||||
(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
|
||||
(semaphore-post sema)
|
||||
(semaphore-post sema2)
|
||||
(let ([first (semaphore-wait-multiple (list sema sema2))])
|
||||
(test #t semaphore? first)
|
||||
(test (if (eq? first sema) sema2 sema) semaphore-wait-multiple (list sema sema2)))
|
||||
(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME)
|
||||
|
||||
(arity-test semaphore-wait-multiple 1 3)
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
|
||||
; Test the oe extension
|
||||
|
||||
(if (not (defined? 'Section))
|
||||
(load-relative "testing.ss"))
|
||||
|
||||
(define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init))))
|
||||
(define b3 (class object% () (public [z1 13][z2 14]) (sequence (super-init))))
|
||||
|
||||
(define i1 (mktinterface (interface () z1)))
|
||||
(define i3 (mktinterface (interface () z2)))
|
||||
|
||||
(define c1 (mktclass b1 i1))
|
||||
(define c3 (mktclass b3 i3))
|
||||
|
||||
(define o1 (make-object c1 1 2))
|
||||
(define o2 (make-object c1 3 4))
|
||||
(define o3 (make-object c3 5 6))
|
||||
|
||||
(test 5 'oee (send o1 get-y))
|
||||
(test 5 'oee (send o2 get-y))
|
||||
(test 5 'oee (send o3 get-y))
|
||||
|
||||
(test 7 'oee (send o1 get-z1))
|
||||
(test 7 'oee (send o2 get-z1))
|
||||
(test 13 'oee (send o3 get-z1))
|
||||
|
||||
(test 8 'oee (send o1 get-z2))
|
||||
(test 8 'oee (send o2 get-z2))
|
||||
(test 14 'oee (send o3 get-z2))
|
||||
|
||||
(test 1 'oee (send o1 get-x1))
|
||||
(test 3 'oee (send o2 get-x1))
|
||||
(test 5 'oee (send o3 get-x1))
|
||||
|
||||
(test 2 'oee (send o1 get-x2))
|
||||
(test 4 'oee (send o2 get-x2))
|
||||
(test 6 'oee (send o3 get-x2))
|
||||
|
||||
(error-test '(mktinterface 0) exn:object:interface-type?)
|
||||
(error-test '(mktclass 0 i1) exn:object:class-type?)
|
||||
(error-test '(mktclass b1 0) exn:object:interface-type?)
|
||||
(error-test '(mktclass b1 (interface () not-there)) exn:object:implement?)
|
||||
|
||||
(report-errs)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(require mzlib/package
|
||||
(require scheme/package
|
||||
mzlib/pretty
|
||||
syntax/toplevel)
|
||||
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
(define open-context-forms
|
||||
(list (lambda (l) `(begin ,@l))
|
||||
(lambda (l) `(let () ,@l))
|
||||
(lambda (l) `(package other () ,@l))))
|
||||
(lambda (l) `(define-package other () ,@l))))
|
||||
|
||||
(define open-forms
|
||||
(apply
|
||||
|
|
@ -20,25 +20,14 @@
|
|||
(map (lambda (ctx)
|
||||
(ctx `((,open-form pk-to-open) (check var-to-use))))
|
||||
open-context-forms))
|
||||
(list 'open 'open*))))
|
||||
(list 'open-package 'open*-package))))
|
||||
|
||||
(define (mk-package-shell-forms name)
|
||||
(list (lambda (body) `(package ,name all-defined ,@body))
|
||||
(lambda (body) `(package ,name (var-to-use) ,@body))
|
||||
(lambda (body) `(package* ,name all-defined ,@body))
|
||||
(lambda (body) `(package* ,name (var-to-use) ,@body))))
|
||||
(list (lambda (body) `(define-package ,name #:all-defined ,@body))
|
||||
(lambda (body) `(define-package ,name (var-to-use) ,@body))))
|
||||
|
||||
(define package-shell-forms
|
||||
(append (mk-package-shell-forms 'pk-to-open)
|
||||
(apply
|
||||
append
|
||||
(map (lambda (rename-potential-package)
|
||||
(map (lambda (psf)
|
||||
(lambda (body)
|
||||
`(begin ,(psf body) (,rename-potential-package pk-to-open hidden-pk-to-open))))
|
||||
(mk-package-shell-forms 'hidden-pk-to-open)))
|
||||
(list 'rename-potential-package
|
||||
'rename*-potential-package)))))
|
||||
(mk-package-shell-forms 'pk-to-open))
|
||||
|
||||
(define defn-forms
|
||||
(list '(define var-to-use 'this-is-right)
|
||||
|
|
@ -88,8 +77,7 @@
|
|||
|
||||
(define do-threshold 3)
|
||||
|
||||
(let ([m ((current-module-name-resolver) '(lib "package.ss") #f #f)]
|
||||
[ns (current-namespace)]
|
||||
(let ([ns (current-namespace)]
|
||||
[total (length all-forms)]
|
||||
[cnt 0])
|
||||
(for-each (lambda (form)
|
||||
|
|
@ -97,9 +85,9 @@
|
|||
(when (zero? (modulo cnt 100))
|
||||
(printf "~a/~a~n" cnt total))
|
||||
(when ((add1 (random 10)) . >= . do-threshold)
|
||||
; (pretty-print form)
|
||||
;; (pretty-print form)
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-attach-module ns m)
|
||||
(namespace-attach-module ns 'scheme/package)
|
||||
(let ([done? #f]
|
||||
[mode "top-level"])
|
||||
(with-handlers ([exn:fail?
|
||||
|
|
@ -107,7 +95,7 @@
|
|||
(printf "At ~a:~n" mode)
|
||||
(pretty-print form)
|
||||
(raise x))])
|
||||
(eval `(require (lib "package.ss")))
|
||||
(eval `(require scheme/package))
|
||||
(eval `(define check ,(lambda (x)
|
||||
(check x)
|
||||
(set! done? #t))))
|
||||
|
|
@ -117,12 +105,12 @@
|
|||
(set! done? #f)
|
||||
(set! mode "top-level expand")
|
||||
(eval-syntax (expand-top-level-with-compile-time-evals
|
||||
(datum->syntax-object #f form)))
|
||||
(datum->syntax #f form)))
|
||||
(unless done?
|
||||
(error "check" "didn't execute after expand"))
|
||||
(let ([mod (lambda (name)
|
||||
`(module ,name mzscheme
|
||||
(require (lib "package.ss"))
|
||||
`(module ,name scheme/base
|
||||
(require scheme/package)
|
||||
(define check ,(lambda (x)
|
||||
(check x)
|
||||
(set! done? #t)))
|
||||
|
|
@ -130,13 +118,13 @@
|
|||
(set! done? #f)
|
||||
(set! mode "module")
|
||||
(eval (mod 'm))
|
||||
(eval `(require m))
|
||||
(eval `(require 'm))
|
||||
(unless done?
|
||||
(error "check" "module didn't execute"))
|
||||
(set! done? #f)
|
||||
(set! mode "module expand")
|
||||
(eval-syntax (expand (mod 'n)))
|
||||
(eval `(require n))
|
||||
(eval `(require 'n))
|
||||
(unless done?
|
||||
(error "check" "module didn't execute after expand"))))))))
|
||||
all-forms))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
|
||||
do-not-run-me-yet
|
||||
|
||||
;; Runs 3 threads perfoming the test suite simultaneously. Each
|
||||
;; thread creates a directory sub<n> to run in, so that filesystem
|
||||
;; tests don't collide.
|
||||
|
|
@ -36,6 +38,7 @@
|
|||
[cust (list-ref custodians (sub1 n))]
|
||||
[ql (namespace-variable-value 'quiet-load #f
|
||||
(lambda () #f))])
|
||||
(namespace-attach-module (current-namespace) 'scheme/init ns)
|
||||
(parameterize ([current-custodian cust])
|
||||
(thread
|
||||
(lambda ()
|
||||
|
|
@ -43,7 +46,7 @@
|
|||
n
|
||||
(lambda ()
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require '(for-syntax scheme/base))
|
||||
(namespace-require '(lib "scheme/init"))
|
||||
(eval `(define Section-prefix ,(format "~a:" n)))
|
||||
(when ql
|
||||
(eval `(define quiet-load (quote ,ql))))
|
||||
|
|
|
|||
|
|
@ -1,182 +0,0 @@
|
|||
|
||||
(define ones-case
|
||||
(make-struct-case
|
||||
(list
|
||||
one00?
|
||||
one01?
|
||||
one02?
|
||||
one03?
|
||||
|
||||
one10?
|
||||
one11?
|
||||
one12?
|
||||
one13?
|
||||
|
||||
one20?
|
||||
one21?
|
||||
one22?
|
||||
one23?
|
||||
|
||||
one30?
|
||||
one31?
|
||||
one32?
|
||||
one33?)
|
||||
|
||||
(list
|
||||
(lambda (x) 'one00)
|
||||
(lambda (x) 'one01)
|
||||
(lambda (x) 'one02)
|
||||
(lambda (x) 'one03)
|
||||
|
||||
(lambda (x) 'one10)
|
||||
(lambda (x) 'one11)
|
||||
(lambda (x) 'one12)
|
||||
(lambda (x) 'one13)
|
||||
|
||||
(lambda (x) 'one20)
|
||||
(lambda (x) 'one21)
|
||||
(lambda (x) 'one22)
|
||||
(lambda (x) 'one23)
|
||||
|
||||
(lambda (x) 'one30)
|
||||
(lambda (x) 'one31)
|
||||
(lambda (x) 'one32)
|
||||
(lambda (x) 'one33))))
|
||||
|
||||
(define multi-case
|
||||
(make-struct-case
|
||||
(list
|
||||
two130?
|
||||
two131?
|
||||
two132?
|
||||
two133?
|
||||
|
||||
one10?
|
||||
one11?
|
||||
one12?
|
||||
one13?
|
||||
|
||||
one20?
|
||||
one21?
|
||||
one22?
|
||||
one23?
|
||||
|
||||
base0?
|
||||
base1?
|
||||
base2?
|
||||
base3?)
|
||||
|
||||
(list
|
||||
(lambda (x) 'two130)
|
||||
(lambda (x) 'two131)
|
||||
(lambda (x) 'two132)
|
||||
(lambda (x) 'two133)
|
||||
|
||||
(lambda (x) 'one10)
|
||||
(lambda (x) 'one11)
|
||||
(lambda (x) 'one12)
|
||||
(lambda (x) 'one13)
|
||||
|
||||
(lambda (x) 'one20)
|
||||
(lambda (x) 'one21)
|
||||
(lambda (x) 'one22)
|
||||
(lambda (x) 'one23)
|
||||
|
||||
(lambda (x) 'base0)
|
||||
(lambda (x) 'base1)
|
||||
(lambda (x) 'base2)
|
||||
(lambda (x) 'base3))
|
||||
|
||||
(lambda (x) x)))
|
||||
|
||||
(letrec ([bundle
|
||||
(lambda (l f)
|
||||
(if (null? l)
|
||||
null
|
||||
(list* f (car l) (cadr l)
|
||||
(bundle (cddr l) f))))])
|
||||
(check (append
|
||||
(bundle ones-test ones-case)
|
||||
(bundle multi-test multi-case)
|
||||
(list base1-a x11 1
|
||||
one11-a x11 2
|
||||
one10-a x10 1
|
||||
|
||||
base1-a x31 1
|
||||
one31-z x31 4
|
||||
|
||||
base2-l x132 1
|
||||
two132-a x132 6
|
||||
one32-y x132 4))))
|
||||
|
||||
(test #t arity-at-least? (multi-case (arity void)))
|
||||
|
||||
(arity-test multi-case 1 1)
|
||||
|
||||
(error-test `(,ones-case 6) type?)
|
||||
(error-test `(,multi-case 6) type?)
|
||||
|
||||
(error-test `(,ones-case (arity void)) exn:else?)
|
||||
|
||||
(test (void) (make-struct-case null null void) x00)
|
||||
(test #t procedure? (make-struct-case null null))
|
||||
|
||||
(error-test `((make-struct-case null null) x00) exn:else?)
|
||||
|
||||
(error-test `(make-struct-case (list 8) (list void)))
|
||||
(error-test `(make-struct-case (list exn:misc? 8) (list void void)))
|
||||
(error-test `(make-struct-case (list exn:misc? 8 exn?) (list void void void)))
|
||||
(error-test `(make-struct-case exn? (list void)))
|
||||
(error-test `(make-struct-case (list* exn:misc? exn?) (list void)))
|
||||
|
||||
(error-test `(make-struct-case (list exn?) (list 8)))
|
||||
(error-test `(make-struct-case (list exn?) (list (lambda () 8))))
|
||||
(error-test `(make-struct-case (list exn:misc? exn?)
|
||||
(list void string-set!)))
|
||||
(error-test `(make-struct-case (list exn:misc? exn:syntax? exn?)
|
||||
(list void void string-set!)))
|
||||
(error-test `(make-struct-case (list exn?) void))
|
||||
(error-test `(make-struct-case (list exn?) (list* void void)))
|
||||
|
||||
(error-test `(make-struct-case (list exn:misc?) (list void void))
|
||||
exn:application:list-sizes?)
|
||||
(error-test `(make-struct-case (list exn:misc? exn?) (list void))
|
||||
exn:application:list-sizes?)
|
||||
|
||||
(arity-test make-struct-case 2 3)
|
||||
|
||||
(test 0 (struct-case-lambda x (else 0)) (arity void))
|
||||
(test (arity void) (struct-case-lambda x (else)) (arity void))
|
||||
(test (arity void) (struct-case-lambda x (arity-at-least?)) (arity void))
|
||||
(test 0 (struct-case-lambda x (arity-at-least? 0) (else 1)) (arity void))
|
||||
|
||||
(define s (struct-case-lambda x
|
||||
[exn? 'exn]
|
||||
[arity-at-least? x]
|
||||
[else (cons x 5)]))
|
||||
|
||||
(test 'exn s (make-exn 1 2))
|
||||
(test (arity void) s (arity void))
|
||||
(test (cons x00 5) s x00)
|
||||
|
||||
(arity-test s 1 1)
|
||||
|
||||
(error-test '(s 9))
|
||||
(error-test '(struct-case-lambda) syntaxe?)
|
||||
(error-test '(struct-case-lambda 5) syntaxe?)
|
||||
(error-test '(struct-case-lambda x . 5) syntaxe?)
|
||||
(error-test '(struct-case-lambda x ()) syntaxe?)
|
||||
(error-test '(struct-case-lambda x else) syntaxe?)
|
||||
(error-test '(struct-case-lambda x (else 9) (exn? 8)) syntaxe?)
|
||||
|
||||
(define time-branch
|
||||
(lambda (proc list)
|
||||
(time
|
||||
(let loop ([n 1000])
|
||||
(unless (zero? n)
|
||||
(let loop ([l list])
|
||||
(unless (null? l)
|
||||
(proc (car l))
|
||||
(loop (cddr l))))
|
||||
(loop (sub1 n)))))))
|
||||
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
|
||||
(define child? (member "child" (vector->list (current-command-line-arguments))))
|
||||
|
||||
(define a-lot 500000)
|
||||
|
||||
(unless child?
|
||||
(load-relative "loadtest.ss")
|
||||
|
||||
(let ([path (find-executable-path (find-system-path 'exec-file) #f)])
|
||||
(let-values ([(subproc in out /err) (subprocess #f #f (current-error-port)
|
||||
path "-rq"
|
||||
(build-path (current-load-relative-directory)
|
||||
"subproc2.ss")
|
||||
"child")])
|
||||
(test 'running subprocess-status subproc)
|
||||
(test out object-wait-multiple 0 out)
|
||||
(test #f object-wait-multiple 0 in)
|
||||
(fprintf out "go~n")
|
||||
|
||||
(test "going" read-line in)
|
||||
|
||||
(test #t
|
||||
positive?
|
||||
;; Push a-lot chars; should block at least once:
|
||||
(let ([s (make-string a-lot #\a)])
|
||||
(let loop ([offset 0])
|
||||
(let ([ready? (object-wait-multiple 0 out)])
|
||||
(printf "~a ~a~n" offset ready?)
|
||||
(+ (if ready? 0 1)
|
||||
(let ([n (write-string-avail s out offset)])
|
||||
(if (= (+ n offset) a-lot)
|
||||
0
|
||||
(loop (+ offset n)))))))))
|
||||
|
||||
(test "done" read-line in)
|
||||
|
||||
'ok)))
|
||||
|
||||
(when child?
|
||||
(with-handlers ([void (lambda (x)
|
||||
(fprintf (current-error-port) "CHILD ")
|
||||
(raise x))])
|
||||
(if (equal? "go" (read-line (current-input-port) 'any))
|
||||
(printf "going~n")
|
||||
(printf "not go!~n"))
|
||||
|
||||
(fprintf (current-error-port) "CHILD: starting sleep~n")
|
||||
(sleep 1)
|
||||
(fprintf (current-error-port) "CHILD: finished sleep; reading...~n")
|
||||
|
||||
(unless (= a-lot (string-length (read-string a-lot)))
|
||||
(fprintf (current-error-port) "CHILD: bad read count"))
|
||||
|
||||
(printf "done~n")
|
||||
|
||||
'ok))
|
||||
Loading…
Reference in New Issue
Block a user