Changeset 39004 in project


Ignore:
Timestamp:
09/05/20 22:52:17 (3 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, remove redundant -local, type is interface, update test runner

Location:
release/5/bloom-filter/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/bloom-filter/trunk/bloom-filter.egg

    r38933 r39004  
    88 (author "[[kon lovett]]")
    99 (license "BSD")
    10  (dependencies iset message-digest-primitive message-digest-type message-digest-utils check-errors)
     10 (dependencies iset check-errors
     11  (message-digest-primitive "4.3.0")
     12  (message-digest-type "4.2.0")
     13  (message-digest-utils "4.2.0"))
    1114 (test-dependencies test srfi-1 srfi-13 sha1 sha2 md5 tiger-hash ripemd)
    1215 (components
  • release/5/bloom-filter/trunk/bloom-filter.scm

    r38379 r39004  
    3030  actual-k
    3131  ;
     32  bloom-filter
    3233  make-bloom-filter
    3334  bloom-filter? check-bloom-filter error-bloom-filter
     
    5556(import (only type-errors-basic signal-bounds-error))
    5657
    57 ;;;
     58;;
    5859
    5960;FIXME should be able to get type as module export
     
    6263(define-type boolean-set iset:integer-set)
    6364
    64 (define-type message-digest-primitive (struct message-digest-primitive))
    65 
     65(include "message-digest-primitive.types")
     66(include "message-digest-type.types")
     67;(define-type message-digest-primitive (struct message-digest-primitive))
    6668(define-type message-digest-primitives (list-of message-digest-primitive))
    6769
    6870(define-type bloom-filter-hasher (* (list-of fixnum) -> (list-of fixnum)))
    69 
    7071(define-type bloom-filter-hashers (list-of bloom-filter-hasher))
    71 
    72 (define-type unsigned-native-integer-getter (* fixnum --> (or fixnum bignum)))
    73 
    74 ;;
    75 
    76 ;mathh
    77 (define-constant LN2 0.69314718055994528622676398299518041312694549560546875) ;ln(2)
    78 (define-constant -LN2^2 -0.48045301391820138814381380143458954989910125732421875) ;-(ln(2)^2)
    79 
    80 ;;
    81 
    82 ;
    83 (define-constant MACHINE-WORD-SIZE (cond-expand (64bit 8) (else 4)))
    84 
    85 (define-inline (object-data-pointer obj)
    86   ;skip over the machine-word header
    87   (pointer+ (object->pointer obj) MACHINE-WORD-SIZE) )
    88 
    89 (define-inline (pointer-word-offset ptr idx)
    90   (assume ((idx fixnum))
    91     (pointer+ ptr (* idx MACHINE-WORD-SIZE)) ) )
    92 
    93 (define-inline (object-data-offset obj idx)
    94   (pointer-word-offset (object-data-pointer obj) idx) )
    95 
    96 ;NOTE ((cond-expand (64bit pointer-u64-ref) (else ...) (object-data-offset ...))) Fails!
    97 
    98 (: wordvector-ref unsigned-native-integer-getter)
    99 ;
    100 (define (wordvector-ref obj idx)
    101   (cond-expand
    102     (64bit  (pointer-u64-ref (object-data-offset obj idx)))
    103     (else   (pointer-u32-ref (object-data-offset obj idx)))) )
    104 
    105 ;;; Record Type
    106 
    10772(define-type bloom-filter (struct bloom-filter))
    10873
     74(define-type unsigned-native-integer-ref (* fixnum --> (or fixnum bignum)))
     75
     76(: wordvector-ref unsigned-native-integer-ref)
    10977(: *make-bloom-filter (fixnum fixnum fixnum boolean-set bloom-filter-hashers message-digest-primitives -> bloom-filter))
    11078(: bloom-filter? (* -> boolean : bloom-filter))
     
    11785(: *bloom-filter-hashers (bloom-filter --> bloom-filter-hashers))
    11886(: *bloom-filter-algorithms (bloom-filter --> message-digest-primitives))
    119 ;
     87(: message-digest-primitive-lengths (message-digest-primitives --> (list-of fixnum)))
     88(: bloom-filter-indices (bloom-filter * -> list))
     89(: bloom-filter-k-indices (bloom-filter * -> list))
     90(: bloom-filter-foldl (bloom-filter procedure 'a list -> 'a))
     91(: message-digest-result->integers (* fixnum fixnum fixnum (list-of fixnum) -> (list-of fixnum)))
     92(: make-bloom-filter-hasher (message-digest-primitive fixnum -> bloom-filter-hasher))
     93(: optimum-size (float fixnum --> fixnum fixnum))
     94(: optimum-k (fixnum fixnum --> fixnum))
     95(: optimum-m (fixnum fixnum --> fixnum))
     96(: p-random-one-bit (fixnum fixnum fixnum --> float))
     97(: p-false-positive (fixnum fixnum fixnum --> float))
     98(: desired-m (float fixnum #!optional fixnum --> fixnum fixnum float))
     99(: actual-k (message-digest-primitives --> fixnum))
     100(: bloom-filter-algorithms (bloom-filter --> message-digest-primitives))
     101(: bloom-filter-n (bloom-filter -> fixnum))
     102(: bloom-filter-m (bloom-filter --> fixnum))
     103(: bloom-filter-k (bloom-filter --> fixnum))
     104(: make-bloom-filter ((or fixnum float) (or fixnum message-digest-primitives) #!optional (or fixnum message-digest-primitives) -> bloom-filter))
     105(: bloom-filter-p-false-positive (bloom-filter -> float))
     106(: bit-on! (boolean-set fixnum -> boolean-set))
     107(: *make-bit-counter (boolean-set -> (fixnum fixnum -> fixnum)))
     108(: *bloom-filter-exists? (bloom-filter * -> boolean))
     109(: bloom-filter-exists? (bloom-filter * -> boolean))
     110(: bloom-filter-set! (bloom-filter * -> void))
     111
     112;;
     113
     114;mathh
     115(define-constant LN2 0.69314718055994528622676398299518041312694549560546875) ;ln(2)
     116(define-constant -LN2^2 -0.48045301391820138814381380143458954989910125732421875) ;-(ln(2)^2)
     117
     118;;
     119
     120(define-constant MACHINE-WORD-SIZE (cond-expand (64bit 8) (else 4)))
     121
     122(define-inline (object-data-pointer obj)
     123  ;skip over the machine-word header
     124  (pointer+ (object->pointer obj) MACHINE-WORD-SIZE) )
     125
     126(define-inline (pointer-word-offset ptr idx)
     127  (assume ((idx fixnum))
     128    (pointer+ ptr (* idx MACHINE-WORD-SIZE)) ) )
     129
     130(define-inline (object-data-offset obj idx)
     131  (pointer-word-offset (object-data-pointer obj) idx) )
     132
     133;NOTE ((cond-expand (64bit pointer-u64-ref) (else ...) (object-data-offset ...))) Fails!
     134
     135(define (wordvector-ref obj idx)
     136  (cond-expand
     137    (64bit  (pointer-u64-ref (object-data-offset obj idx)))
     138    (else   (pointer-u32-ref (object-data-offset obj idx)))) )
     139
     140;;; Record Type
     141
     142
    120143(define-record-type bloom-filter
    121144  (*make-bloom-filter n m k bits hashes mdps)
     
    128151  (mdps *bloom-filter-algorithms) )
    129152
    130 ;;; Support
    131 
    132 ;;
    133 
    134 (: message-digest-primitive-lengths (message-digest-primitives --> (list-of fixnum)))
    135 ;
     153;; Support
     154
     155;;
     156
    136157(define (message-digest-primitive-lengths mdps)
    137158  (map message-digest-primitive-digest-length mdps) )
    138159
    139 (: bloom-filter-indices (bloom-filter * --> list))
    140 ;
    141160(define (bloom-filter-indices bf obj)
    142161  (foldl
     
    145164    (*bloom-filter-hashers bf)) )
    146165
    147 (: bloom-filter-k-indices (bloom-filter * --> list))
    148 ;
    149166(define (bloom-filter-k-indices bf obj)
    150167  (take! (bloom-filter-indices bf obj) (*bloom-filter-k bf)) )
    151168
    152 (: bloom-filter-foldl (bloom-filter procedure * list --> *))
    153 ;
    154169(define (bloom-filter-foldl bf func init obj)
    155170  (foldl func init (bloom-filter-k-indices bf obj)) )
    156171
    157 (: message-digest-result->integers (* fixnum fixnum fixnum (list-of fixnum) -> (list-of fixnum)))
    158 ;
     172(define-inline (*make-bit-counter bits)
     173  (lambda (cnt idx) (if (bit-vector-ref bits idx) (add1 cnt) cnt)) )
     174
     175(define-inline (*bloom-filter-exists? bf obj)
     176  (let* (
     177    (bits (*bloom-filter-bits bf))
     178    (bitcnt (bloom-filter-foldl bf (*make-bit-counter bits) 0 obj)) )
     179    (<= (*bloom-filter-k bf) bitcnt) ) )
     180
    159181(define (message-digest-result->integers obj m wrdcnt bytrem ls)
    160182  ;
     
    181203  (reverse! (cons (partial-word) (whole-words))) )
    182204
    183 (: make-bloom-filter-hasher (message-digest-primitive fixnum -> bloom-filter-hasher))
    184 ;
    185205(define (make-bloom-filter-hasher mdp m)
    186   (let (
    187     (len (message-digest-primitive-digest-length mdp)) )
    188     (let (
    189       (wrdcnt (quotient len MACHINE-WORD-SIZE) )
    190       (bytrem (modulo len MACHINE-WORD-SIZE) ) )
    191       ;returns a list of hash values for the supplied object
    192       (lambda (obj ls)
    193         (let (
    194           (blb (message-digest-object mdp obj 'blob)) )
    195           (message-digest-result->integers blb m wrdcnt bytrem ls) ) ) ) ) )
    196 
    197 ;;; Calculators
     206  (let* (
     207    (len (message-digest-primitive-digest-length mdp))
     208    (wrdcnt (quotient len MACHINE-WORD-SIZE) )
     209    (bytrem (modulo len MACHINE-WORD-SIZE) ) )
     210    ;returns a list of hash values for the supplied object
     211    (lambda (obj ls)
     212      (let (
     213        (blb (message-digest-object mdp obj 'blob)) )
     214        (message-digest-result->integers blb m wrdcnt bytrem ls) ) ) ) )
     215
     216;; Calculators
    198217
    199218;; Actual optimal: (expt (* n (log2 (/ m (- m 1)))) -1)
     
    202221;n : capacity, p : probability of false-positive
    203222;=> m : bits, k : hashes
    204 (: optimum-size (float fixnum --> fixnum fixnum))
    205223;
    206224(define (optimum-size p n)
     
    211229    (values (inexact->exact mx) (inexact->exact kx)) ) )
    212230
    213 (: optimum-k (fixnum fixnum --> fixnum))
    214 ;
    215231(define (optimum-k n m)
    216232  (let (
     
    219235    (inexact->exact (ceiling (* LN2 (/ mx nx)))) ) )
    220236
    221 (: optimum-m (fixnum fixnum --> fixnum))
    222 ;
    223237(define (optimum-m k n)
    224238  (let (
     
    227241    (inexact->exact (ceiling (/ (* nx kx) LN2))) ) )
    228242
    229 (: p-random-one-bit (fixnum fixnum fixnum --> float))
    230 ;
    231243(define (p-random-one-bit k n m)
    232244  (let (
     
    236248    (- 1.0 (expt (- 1.0 (/ 1.0 mx)) (* kx nx))) ) )
    237249
    238 (: p-false-positive (fixnum fixnum fixnum --> float))
    239 ;
    240250(define (p-false-positive k n m)
    241251  (let (
     
    243253    (expt (p-random-one-bit k n m) kx) ) )
    244254
    245 (: desired-m (float fixnum #!optional fixnum --> fixnum fixnum float))
    246 ;
    247255(define (desired-m p n #!optional opt-k)
    248256  (check-flonum 'desired-m p 'p)
     
    262270            (loop (+ m n)) ) ) ) ) ) )
    263271
    264 (: actual-k (message-digest-primitives --> fixnum))
    265 ;
    266272(define (actual-k mdps)
    267273  (let ((wrdcntr (lambda (tot len) (+ tot (quotient len MACHINE-WORD-SIZE)))))
    268274    (foldl wrdcntr 0 (message-digest-primitive-lengths mdps)) ) )
    269275
    270 ;;; Bloom Filter
     276;; Bloom Filter
    271277
    272278(define-check+error-type bloom-filter bloom-filter?)
    273279
    274 (: bloom-filter-algorithms (bloom-filter --> message-digest-primitives))
    275 ;
    276280(define (bloom-filter-algorithms bf)
    277281  (list-copy
     
    279283      (check-bloom-filter 'bloom-filter-algorithms bf))) )
    280284
    281 (: bloom-filter-n (bloom-filter -> fixnum))
    282 ;
    283285(define (bloom-filter-n bf)
    284286  (*bloom-filter-n (check-bloom-filter 'bloom-filter-n bf)) )
    285287
    286 (: bloom-filter-m (bloom-filter --> fixnum))
    287 ;
    288288(define (bloom-filter-m bf)
    289289  (*bloom-filter-m (check-bloom-filter 'bloom-filter-m bf)) )
    290290
    291 (: bloom-filter-k (bloom-filter --> fixnum))
    292 ;
    293291(define (bloom-filter-k bf)
    294292  (*bloom-filter-k (check-bloom-filter 'bloom-filter-k bf)) )
     
    296294;FIXME make-bloom-filter type is ugh
    297295;( p n mdps) | ( m mdps [k])
    298 (: make-bloom-filter ((or fixnum float) (or fixnum message-digest-primitives) #!optional (or fixnum message-digest-primitives) -> bloom-filter))
    299296;
    300297(define (make-bloom-filter m mdps #!optional des-k)
    301298  ;processing ( m mdps [k] ) or ( p n mdps ) ?
    302   (if (list? mdps)
    303     (check-positive-fixnum 'make-bloom-filter m 'm)
     299  (let (
     300    (m m)
     301    (mdps mdps)
     302    (des-k des-k) )
     303    (if (list? mdps)
     304      (check-positive-fixnum 'make-bloom-filter m 'm)
     305      (let (
     306        (p (check-flonum 'make-bloom-filter m 'p))
     307        (n (check-positive-fixnum 'make-bloom-filter mdps 'n)) )
     308        (check-open-interval 'make-bloom-filter p  0.0 1.0 'p)
     309        (set! mdps des-k)
     310        (set!-values (m des-k) (optimum-size p n)) ) )
     311    ;algorithms
     312    (for-each
     313      (cut check-message-digest-primitive 'make-bloom-filter <>)
     314      (check-list 'make-bloom-filter mdps 'mdps))
     315    ;get the "desired" # of hash values (k)
    304316    (let (
    305       (p (check-flonum 'make-bloom-filter m 'p))
    306       (n (check-positive-fixnum 'make-bloom-filter mdps 'n)) )
    307       (check-open-interval 'make-bloom-filter p  0.0 1.0 'p)
    308       (set! mdps des-k)
    309       (set!-values (m des-k) (optimum-size p n)) ) )
    310   ;algorithms
    311   (for-each
    312     (cut check-message-digest-primitive 'make-bloom-filter <>)
    313     (check-list 'make-bloom-filter mdps 'mdps))
    314   ;get the "desired" # of hash values (k)
    315   (let (
    316     (act-k (actual-k mdps)) )
    317     (if (not des-k) (set! des-k act-k)
    318       (when (< act-k (check-positive-fixnum 'make-bloom-filter des-k))
    319         ;FIXME tell them how !
    320         (error 'make-bloom-filter "insufficient hash functions supplied" act-k des-k) ) ) )
    321   ;bloom filter is a multi-hash into a bitvector
    322   (let (
    323     (bits (make-bit-vector m))
    324     (hashers (map (cut make-bloom-filter-hasher <> m) mdps)) )
    325     (*make-bloom-filter 0 m des-k bits hashers mdps) ) )
    326 
    327 (: bloom-filter-p-false-positive (bloom-filter -> float))
    328 ;
     317      (act-k (actual-k mdps)) )
     318      (if (not des-k)
     319        (set! des-k act-k)
     320        (when (< act-k (check-positive-fixnum 'make-bloom-filter des-k))
     321          ;FIXME tell them how !
     322          (error 'make-bloom-filter "insufficient hash functions supplied" act-k des-k) ) ) )
     323    ;bloom filter is a multi-hash into a bitvector
     324    (let (
     325      (bits (make-bit-vector m))
     326      (hashers (map (cut make-bloom-filter-hasher <> m) mdps)) )
     327      (*make-bloom-filter 0 m des-k bits hashers mdps) ) ) )
     328
    329329(define (bloom-filter-p-false-positive bf . n)
    330330  (check-bloom-filter 'bloom-filter-p-false-positive bf)
     
    334334    (*bloom-filter-m bf)) )
    335335
    336 (: bit-on! (boolean-set fixnum -> boolean-set))
    337 ;
    338336(define (bit-on! bits idx)
    339337  (bit-vector-set! bits idx #t)
    340338  bits )
    341339
    342 (: *make-bit-counter (boolean-set -> (fixnum fixnum -> fixnum)))
    343 ;
    344 (define-inline (*make-bit-counter bits)
    345   (lambda (cnt idx) (if (bit-vector-ref bits idx) (add1 cnt) cnt)) )
    346 
    347 (: *bloom-filter-exists? (bloom-filter * -> boolean))
    348 ;
    349 (define-inline (*bloom-filter-exists? bf obj)
    350   (let* (
    351     (bits (*bloom-filter-bits bf))
    352     (bitcnt (bloom-filter-foldl bf (*make-bit-counter bits) 0 obj)) )
    353     (<= (*bloom-filter-k bf) bitcnt) ) )
    354 
    355 (: bloom-filter-exists? (bloom-filter * --> boolean))
    356 ;
    357340(define (bloom-filter-exists? bf obj)
    358341  (*bloom-filter-exists? (check-bloom-filter 'bloom-filter-exists? bf) obj) )
    359342
    360 (: bloom-filter-set! (bloom-filter * -> void))
    361 ;
    362343(define (bloom-filter-set! bf obj)
    363344  ;tracks actual pop (n) so cannot "reset"
  • release/5/bloom-filter/trunk/tests/bloom-filter-test.scm

    r38905 r39004  
    2323(import (only (chicken sort) sort sort!))
    2424(import (only (chicken random) pseudo-random-integer))
    25 (import (only (srfi 1) every filter list-copy map!))
     25(import (only (srfi 1) first second third every filter list-copy map!))
    2626(import (only (srfi 13) string-reverse))
    2727(import message-digest-primitive)
     
    3232
    3333(: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
    34 ;
     34
    3535(define (shuffle ls #!optional (rand pseudo-random-integer))
    3636  (define (tag-gen) (rand most-positive-fixnum))
     
    4242
    4343(: read-file ((or string input-port) #!optional (procedure (input-port) *) fixnum -> list))
    44 ;
     44
    4545(define (read-file inp-or-fil #!optional (reader read) max)
    4646  (import (chicken io))
     
    164164        mirrored-word-list))))
    165165
    166 ;Shuffle the Hashers
     166;Shuffling Hashers to test Commutative property
     167;(seems to hold; failures do not coincide - on 1st glance )
    167168(set! mdps (shuffle mdps))
    168169
     
    173174(define P 2.47E-05)
    174175
    175 (let (
    176   (MK #f)
    177   (bf #f)
    178   (false-positives '()) )
     176(let ((MK (the (list fixnum fixnum) '(0 0)))
     177      (false-positives (the (list-of string) '()))
     178      (bf (the (or boolean (struct bloom-filter)) #f)) )
    179179
    180180  (test-group "Words In List, All K"
     
    182182    (test-assert (= 2 (length (receive (optimum-size P N)))))
    183183    (set! MK (receive (optimum-size P N)))
    184     (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (car MK) (cadr MK) P)
     184    (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (first MK) (second MK) P)
    185185    (test-success "Make"
    186186      (set! bf (make-bloom-filter P N mdps)))
     
    199199) )
    200200
    201 (let (
    202   (MKP* #f)
    203   (MKP #f)
    204   (bf #f)
    205   (false-positives '()) )
     201(let ((MKP* (the (list fixnum fixnum float) '(0 0 0.0)))
     202      (MKP (the (list fixnum fixnum float) '(0 0 0.0)))
     203      (false-positives (the (list-of string) '()))
     204      (bf (the (or boolean (struct bloom-filter)) #f)) )
    206205
    207206  (test-group "Words In List, Actual K"
     
    211210    (test-assert (= 3 (length (receive (desired-m P N)))))
    212211    (set! MKP* (receive (desired-m P N)))
    213     (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (car MKP*) (cadr MKP*) (caddr MKP*))
     212    (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (first MKP*) (second MKP*) (third MKP*))
    214213
    215214    (test-assert (= 3 (length (receive (desired-m P N (actual-k mdps))))))
    216215    (set! MKP (receive (desired-m P N (actual-k mdps))))
    217     (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (car MKP) (cadr MKP) (caddr MKP))
     216    (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (first MKP) (second MKP) (third MKP))
    218217
    219218    (test-success "Make"
    220       (set! bf (make-bloom-filter (car MKP) mdps)))
     219      (set! bf (make-bloom-filter (first MKP) mdps)))
    221220    (test-success "Add Bloom Filter"
    222221      (for-each (cut bloom-filter-set! bf <>) test-word-list))
     
    234233) )
    235234
    236 (let (
    237   (MKP #f)
    238   (bf #f)
    239   (false-positives '()) )
     235(let ((MKP (the (list fixnum fixnum float) '(0 0 0.0)))
     236      (false-positives (the (list-of string) '()))
     237      (bf (the (or boolean (struct bloom-filter)) #f)) )
    240238
    241239  (test-group "Words In List, Optimal K"
    242240    (test-assert (= 3 (length (receive (desired-m P N)))))
    243241    (set! MKP (receive (desired-m P N)))
    244     (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (car MKP) (cadr MKP) (caddr MKP))
     242    (glossf "N = ~A, M = ~A, K = ~A, P = ~A" N (first MKP) (second MKP) (third MKP))
    245243
    246244    (test-success "Make"
    247       (set! bf (make-bloom-filter (car MKP) mdps (cadr MKP))))
     245      (set! bf (make-bloom-filter (first MKP) mdps (second MKP))))
    248246    (test-success "Add Bloom Filter"
    249247      (for-each (cut bloom-filter-set! bf <>) test-word-list))
  • release/5/bloom-filter/trunk/tests/run.scm

    r38453 r39004  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     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))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test
Note: See TracChangeset for help on using the changeset viewer.