Changeset 38529 in project for release/5/box/trunk


Ignore:
Timestamp:
04/03/20 18:47:09 (15 months ago)
Author:
Kon Lovett
Message:

*-test runner, fix strict-types exposed test variable type rebinding, cannot use type predicates as "trait" predicates

Location:
release/5/box/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/box/trunk/box.egg

    r38467 r38529  
    1313    (types-file)
    1414    (csc-options
    15       "-O3" "-d1" "-local"
    16       "-no-procedure-checks-for-toplevel-bindings") ) ) )
     15      "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/box/trunk/box.scm

    r38415 r38529  
    2121  make-box-variable
    2222  make-box-location
    23   box? box-variable? box-location?
    24   box-mutable? box-immutable?
    25   box-set! box-ref
     23  box? box-variable?
     24  box-location?
     25  box-mutable?
     26  box-immutable?
     27  box-set!
     28  box-ref
    2629  box-swap!
    2730  box-location
     
    2932  make-box-location-closure
    3033  ;SRFI 111
    31   box immutable-box set-box! unbox
     34  box
     35  immutable-box
     36  set-box!
     37  unbox
    3238  ;
    33   *box-structure? *box-structure-ref *box-structure-set!
    34   *box-procedure? *box-procedure-ref *box-procedure-set!)
     39  *box-structure?
     40  *box-structure-ref
     41  *box-structure-set!
     42  *box-procedure?
     43  *box-procedure-ref
     44  *box-procedure-set!)
    3545
    3646(import scheme)
     
    4656
    4757;;;
    48 
    49 ;;
    50 
    51 (register-feature! 'srfi-111)
    5258
    5359;;
     
    292298  (%box? obj) )
    293299
    294 (: box-variable? (* -> boolean : box-closure))
     300;NOTE these are trait predicates, not type predicates, so not a (DOM -> RNG : TYPE)!
     301
     302(: box-variable? (* -> boolean))
    295303;
    296304(define (box-variable? obj)
    297305  (%box-variable? obj) )
    298306
    299 (: box-location? (* -> boolean : box-closure))
     307(: box-location? (* -> boolean))
    300308;
    301309(define (box-location? obj)
    302310  (%box-location? obj) )
    303311
    304 (: box-immutable? (* -> boolean : box))
     312(: box-immutable? (* -> boolean))
    305313;
    306314(define (box-immutable? obj)
    307315  (or (%box-structure-immutable? obj) (%box-closure-immutable? obj)) )
    308316
    309 (: box-mutable? (* -> boolean : box))
     317(: box-mutable? (* -> boolean))
    310318;
    311319(define (box-mutable? obj)
     
    445453          (display "#&") (write val) ) )
    446454
     455;;;
     456
     457(register-feature! 'srfi-111)
     458
    447459) ;module box
  • release/5/box/trunk/tests/box-test.scm

    r38415 r38529  
    1313
    1414(test-group "Box Mutable"
    15         (let ((tbox #f))
    16     (test-assert (make-box (void)))
    17     (set! tbox (make-box (void)))
     15        (let ((tbox (make-box (void))))
    1816    (test-assert (box? tbox))
    1917    (box-set! tbox #t)
     
    2321
    2422(test-group "Box Immutable"
    25         (let ((tbox #f))
    26     (test-assert (make-box #f #t))
    27     (set! tbox (make-box #f #t))
     23        (let ((tbox (make-box #f #t)))
    2824    (test-assert (box? tbox))
    2925    (test-assert (not (box-ref tbox)))
     
    3127)
    3228
     29(import (only (chicken memory representation) procedure-data))
     30
    3331(test-group "Box References"
    34         (let ((var (void))
    35         (tbox #f))
    36     (test-assert (make-box-variable var))
    37     (set! tbox (make-box-variable var))
     32        (let* ((var (void))
     33               (tbox (make-box-variable var)))
    3834    (test-assert (box? tbox))
    3935    (test-assert (box-variable? tbox))
     
    4743
    4844(test-group "Box Swap"
    49         (let ((tbox #f))
    50     (test-assert (make-box (void)))
    51     (set! tbox (make-box 0))
     45        (let ((tbox (make-box 0)))
    5246    (test-assert (box? tbox))
    5347    (test 1 (box-swap! tbox + 1))
     
    7670
    7771(test-group "Box"
    78         (let ((tbox #f))
    79     (test-assert (box (void)))
    80     (set! tbox (box (void)))
     72        (let ((tbox (box (void))))
    8173    (test-assert (box? tbox))
    8274    (box-set! tbox #t)
     
    8678
    8779(test-group "Immutable-Box"
    88         (let ((tbox #f))
    89     (test-assert (immutable-box #f))
    90     (set! tbox (immutable-box #f))
     80        (let ((tbox (immutable-box #f)))
    9181    (test-assert (box? tbox))
    9282    (test-assert (not (unbox tbox)))
  • release/5/box/trunk/tests/run.scm

    r38467 r38529  
    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.