Changeset 39807 in project
- Timestamp:
- 04/04/21 02:08:05 (3 weeks ago)
- Location:
- release/5/micro-stats/trunk
- Files:
-
- 1 added
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/micro-stats/trunk/micro-stats.scm
r39739 r39807 308 308 (seq:smap *empty-vector* (cut chi-sample <> expected) observed) ) 309 309 310 ;samples : (seq-of observed) 311 ;observed : (seq-of real) 310 ;samples : (seq-of (seq-of real)) 312 311 ;expected : (or real (seq-of real)) 313 312 ; … … 319 318 (define (chi-component o e) (let ((r (- o e))) (/ (* r r) e))) 320 319 321 ;observed : (or real (seq-of real)) 322 ;expected : (or real (seq-of real)) 320 ;(real (seq-of real)) or ((seq-of real) real) 323 321 ; 324 322 (define (chi-sample observed expected) … … 331 329 (seq:smap *empty-vector* (cut chi-component <> expected) observed) ) 332 330 (else 331 (error 'chi-sample "seq X seq unsupported" observed expected) 332 #; ;shouldn't happen 333 333 (seq:smap* 334 334 *empty-vector* 335 335 (lambda (s it) (chi-component (seq:elt s it) (seq:elt expected (seq:index it)))) 336 336 observed) ) ) ) ) 337 ( seq:foldl + 0 components) ) )337 (/ (seq:foldl + 0 components) (seq:size components)) ) ) 338 338 339 339 ) ;module micro-stats -
release/5/micro-stats/trunk/tests/run.scm
r39343 r39807 1 ;;;; run.scm -*- Scheme -*-1 ;;;; run.scm -*- Scheme -*- 2 2 3 (import scheme) 3 ;chicken-install invokes as "<csi> -s run.scm <eggnam>" 4 4 5 ;;; Create Egg Const 5 (import scheme 6 (only (chicken pathname) 7 make-pathname pathname-file pathname-replace-directory pathname-strip-extension) 8 (only (chicken process) system) 9 (only (chicken process-context) command-line-arguments) 10 (only (chicken format) format) 11 (only (chicken file) file-exists? find-files) 12 (only (chicken irregex) irregex irregex-match?)) 6 13 7 (define EGG-NAME "micro-stats") 14 ;; Globals 8 15 9 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>" 16 (define *csc-init-options* '( 17 ;"-disable-interrupts" 18 "-inline-global" "-inline" "-local" 19 "-specialize" "-strict-types" 20 "-optimize-leaf-routines" "-clustering" "-lfa2" 21 "-no-trace" "-no-lambda-info" "-unsafe")) 10 22 11 (import (only (chicken pathname) 12 make-pathname pathname-file pathname-replace-directory pathname-strip-extension)) 13 (import (only (chicken process) system)) 14 (import (only (chicken process-context) argv)) 15 (import (only (chicken format) format)) 16 (import (only (chicken file) file-exists? find-files)) 17 (import (only (chicken irregex) irregex irregex-match?)) 23 (define *test-directory* ".") 24 (define *test-extension* "scm") 25 (define *test-files-rx* (irregex `(: (+ graph) #\- "test" #\. ,*test-extension*))) 18 26 19 ( define *args* (argv))27 (include-relative "run-ident") 20 28 21 (define (egg-name args #!optional (def EGG-NAME)) 29 ;; Support 30 31 (define (system-must cmd) 32 (let ((stat (system cmd))) 33 (if (zero? stat) 0 34 ;failed, actual code irrelevant 35 (exit 1) ) ) ) 36 37 (define (remove rmv? ls) 38 (let loop ((ls ls) (os '())) 39 (cond 40 ((null? ls) (reverse os)) 41 ((rmv? (car ls)) (loop (cdr ls) os)) 42 (else (loop (cdr ls) (cons (car ls) os))) ) ) ) 43 44 (define (remove/list os ls) (remove (cut member <> os) ls)) 45 46 ;; Test Run Support 47 48 (define (egg-name #!optional (args (command-line-arguments)) (def EGG-NAME)) 22 49 (cond 23 (( <= 4 (length *args*)) (cadddr *args*))24 (def def)50 ((not (null? args)) (car args)) 51 (def def) 25 52 (else 26 (error 'run "cannot determine egg-name") 53 (error 'run "cannot determine egg-name")) ) ) 27 54 28 (define *current-directory* (cond-expand (unix "./") (else #f)))29 (define *egg* (egg-name *args*))55 (define (csc-options) 56 (append *csc-incl-options* (remove/list *csc-excl-options* *csc-init-options*)) ) 30 57 31 ;no -disable-interrupts or -no-lambda-info 32 (define *csc-options* "-inline-global -local -inline \ 33 -specialize -optimize-leaf-routines -clustering -lfa2 \ 34 -no-trace -unsafe \ 35 -strict-types") 58 (define (test-filename name) (string-append name "-test")) 36 59 37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm"))) 38 (define (test-filename name) (string-append name "-test")) 39 (define (test-files) (find-files "." #:test *test-files-rx* #:limit 1)) 60 (define (make-test-pathname name) 61 (make-pathname *test-directory* (test-filename name) *test-extension*) ) 40 62 41 (define (ensure-test-source-name name) 63 (define (matching-test-file? x #!optional (remvs '())) 64 (and (irregex-match? *test-files-rx* x) (not (member x remvs))) ) 65 66 (define (test-files) 67 (let ((remvs (map make-test-pathname *test-excl-names*))) 68 (find-files 69 *test-directory* 70 #:test (cut matching-test-file? <> remvs) 71 #:limit 0) ) ) 72 73 (define (ensure-test-pathname name) 42 74 (if (irregex-match? *test-files-rx* name) 43 75 name 44 (make-pathname *current-directory* (test-filename name) "scm") ) ) 76 (make-test-pathname name)) ) 77 78 ;; Run Tests 45 79 46 80 (define (run-test-evaluated source) 47 (format #t "*** ~A - csi***~%" (pathname-file source))48 (system (string-append "csi -s " source)) )81 (format #t "*** csi ~A ***~%" (pathname-file source)) 82 (system-must (string-append "csi -s " source)) ) 49 83 50 84 (define (run-test-compiled source csc-options) 51 (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options) 52 ;csc output is in current directory 53 (system (string-append "csc" " " csc-options " " source)) 54 (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) ) 85 (let ((optstr (apply string-append (intersperse csc-options " ")))) 86 (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr) 87 ;csc output is in current directory 88 (system-must (string-append "csc" " " optstr " " source)) ) 89 (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) ) 55 90 56 ;;; 57 58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*)) 59 (let ( 60 (source (ensure-test-source-name name)) ) 91 (define (run-test #!optional (name (egg-name)) (csc-options (csc-options))) 92 (let ((source (ensure-test-pathname name))) 61 93 (unless (file-exists? source) 62 94 (error 'run "no such file" source) ) … … 65 97 (run-test-compiled source csc-options) ) ) 66 98 67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))99 (define (run-tests #!optional (tests (test-files)) (csc-options (csc-options))) 68 100 (for-each (cut run-test <> csc-options) tests) ) 69 101 70 ;; ; Do Test102 ;; Do Tests 71 103 72 104 (run-tests)
Note: See TracChangeset
for help on using the changeset viewer.