Changeset 35421 in project


Ignore:
Timestamp:
04/22/18 01:15:23 (4 months ago)
Author:
kon
Message:

csi+csc test runner, reflow

Location:
release/4/uuid-lib/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/uuid-lib/trunk/tests/run.scm

    r21905 r35421  
    1 ;;;; uuid-lib-test.scm  -*- Hen -*-
    21
    3 (use test)
    4 (use uuid-lib)
     2(define EGG-NAME "uuid-lib")
    53
    6 (test-group "Common API"
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    75
    8   (test-assert "uuid? <null>" (uuid? (make-uuid)))
    9   (test-assert "uuid? V1" (uuid? (make-uuid 'V1)))
    10   (test-assert "uuid? V4" (uuid? (make-uuid 'V4)))
    11   (test-assert "uuid? time" (uuid? (make-uuid 'time)))
    12   (test-assert "uuid? random" (uuid? (make-uuid 'random)))
     6(use files)
    137
    14   (test-assert "uuid-null? 1" (not (uuid-null? (make-uuid 'V1))))
    15   (test-assert "uuid-null? 2" (uuid-null? (make-uuid)))
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    1610
    17   (test-assert "uuid-clear!" (uuid-null? (uuid-clear! (make-uuid 'V4))))
     11(define *args* (argv))
    1812
    19   (let* ((tuuid (make-uuid 'V4))
    20          (cuuid (uuid-copy tuuid)) )
    21     (test-assert "uuid-copy =" (uuid=? tuuid cuuid))
    22     (test-assert "uuid-copy !eq" (not (eq? tuuid cuuid))) )
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    2315
    24   (test-assert "A uuid is = & <= & >= to itself"
    25     (let ((tuuid (make-uuid 'random)))
    26       (and (uuid=? tuuid tuuid) (uuid<=? tuuid tuuid) (uuid>=? tuuid tuuid))))
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    2724
    28   (test-assert "A !null uuid is \"unique\"" (not (uuid=? (make-uuid 'V1) (make-uuid 'V1))))
    29   (test-assert "A null uuid is not \"unique\"" (uuid=? (make-uuid) (make-uuid)))
     25;;;
    3026
    31   (test-assert "External form of uuid"
    32     (let ((tuuid (make-uuid 'V1)))
    33       (uuid=? tuuid (string->uuid (uuid->string tuuid)))))
    34 )
     27(set! EGG-NAME (egg-name))
    3528
    36 (test-group "Specific API"
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    3737
    38   (test-assert "A uuid is unique" (not (uuid=? (uuid-generate) (uuid-generate))))
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3940
    40   (test-assert "External form of uuid (1)"
    41     (let ((tuuid (uuid-generate)))
    42       (uuid=? tuuid (uuid-parse (uuid-unparse tuuid 'lower)))))
     41;;;
    4342
    44   (test "Error in generate caught correctly"
    45     "bad argument type - invalid variant"
    46     (condition-case (uuid-generate 2)
    47       (v () ((condition-property-accessor 'exn 'message) v))))
    48 
    49   (test "Error in unparse caught correctly"
    50     "bad argument type - invalid case"
    51     (condition-case (uuid-unparse (uuid-generate) 2)
    52       (v () ((condition-property-accessor 'exn 'message) v))))
    53 
    54   (test "Finalizer"
    55     #t
    56     (condition-case (number? (gc))
    57       (v () ((condition-property-accessor 'exn 'message) v))))
    58 )
    59 
    60 (unless (zero? (test-failure-count)) (exit 1))
     43(run-test)
  • release/4/uuid-lib/trunk/uuid-lib.meta

    r27266 r35421  
    1 ;;;; uuid.meta -*- Hen -*-
     1;;;; uuid.meta
    22
    33((egg "uuid-lib.egg")
     
    88 (depends (setup-helper "1.5.2"))
    99 (test-depends test)
    10  (files "uuid-lib.meta" "uuid-lib.setup" "uuid-lib.scm" "tests/run.scm"))
     10 (files
     11  "uuid-lib.meta" "uuid-lib.setup"
     12  "uuid-lib.scm"
     13  "tests/run.scm" "tests/uuid-lib-test.scm"))
  • release/4/uuid-lib/trunk/uuid-lib.scm

    r21905 r35421  
    99(module uuid-lib
    1010
    11   (;export
    12     ;
    13     uuid?
    14     uuid-null?
    15     uuid-compare
    16     uuid=? uuid<? uuid>? uuid<=? uuid>=?
    17     uuid-copy
    18     uuid-clear!
    19     make-uuid
    20     string->uuid uuid->string
    21     ;
    22     uuid-generate
    23     uuid-parse
    24     uuid-unparse
    25     ;Deprecated
    26     uuid<>?)
    27 
    28   (import scheme chicken foreign)
    29 
    30   (use lolevel)
     11(;export
     12  ;
     13  uuid?
     14  uuid-null?
     15  uuid-compare
     16  uuid=? uuid<? uuid>? uuid<=? uuid>=?
     17  uuid-copy
     18  uuid-clear!
     19  make-uuid
     20  string->uuid uuid->string
     21  ;
     22  uuid-generate
     23  uuid-parse
     24  uuid-unparse
     25  ;Deprecated
     26  uuid<>?)
     27
     28(import scheme chicken foreign)
     29
     30(use lolevel)
    3131
    3232;;
     
    9999
    100100(define (uuid-null? uuid)
    101   (and (%uuid? uuid)
    102        (uuid_is_null (unbox-puuid uuid))) )
     101  (and
     102    (%uuid? uuid)
     103    (uuid_is_null (unbox-puuid uuid))) )
    103104
    104105(define (uuid-compare uuid1 uuid2)
    105   (and (%uuid? uuid1)
    106        (%uuid? uuid2)
    107        (let ((cmp (%uuid-compare uuid1 uuid2)))
    108          (cond
    109           ((negative? cmp)  -1)
    110           ((zero? cmp)      0)
    111           (else             1) ) ) ) )
     106  (and
     107    (%uuid? uuid1)
     108    (%uuid? uuid2)
     109    (let ((cmp (%uuid-compare uuid1 uuid2)))
     110      (cond
     111        ((negative? cmp)  -1)
     112        ((zero? cmp)      0)
     113        (else             1) ) ) ) )
    112114
    113115(define (uuid=? uuid1 uuid2)
    114   (and (%uuid? uuid1)
     116  (and
     117    (%uuid? uuid1)
    115118       (%uuid? uuid2)
    116119       (zero? (%uuid-compare uuid1 uuid2))) )
     
    120123
    121124(define (uuid<? uuid1 uuid2)
    122   (and (%uuid? uuid1)
    123        (%uuid? uuid2)
    124        (negative? (%uuid-compare uuid1 uuid2))) )
     125  (and
     126    (%uuid? uuid1)
     127    (%uuid? uuid2)
     128    (negative? (%uuid-compare uuid1 uuid2))) )
    125129
    126130(define (uuid>? uuid1 uuid2)
    127   (and (%uuid? uuid1)
    128        (%uuid? uuid2)
    129        (positive? (%uuid-compare uuid1 uuid2))) )
     131  (and
     132    (%uuid? uuid1)
     133    (%uuid? uuid2)
     134    (positive? (%uuid-compare uuid1 uuid2))) )
    130135
    131136(define (uuid<=? uuid1 uuid2)
    132   (and (%uuid? uuid1)
    133        (%uuid? uuid2)
    134        (let ((comp (%uuid-compare uuid1 uuid2)))
    135          (or (zero? comp) (negative? comp)))) )
     137  (and
     138    (%uuid? uuid1)
     139    (%uuid? uuid2)
     140    (let ((comp (%uuid-compare uuid1 uuid2)))
     141      (or (zero? comp) (negative? comp)))) )
    136142
    137143(define (uuid>=? uuid1 uuid2)
    138   (and (%uuid? uuid1)
    139        (%uuid? uuid2)
    140        (let ((comp (%uuid-compare uuid1 uuid2)))
    141          (or (zero? comp) (positive? comp)))) )
     144  (and
     145    (%uuid? uuid1)
     146    (%uuid? uuid2)
     147    (let ((comp (%uuid-compare uuid1 uuid2)))
     148      (or (zero? comp) (positive? comp)))) )
    142149
    143150(define (uuid-clear! uuid)
    144   (and (%uuid? uuid)
    145        (uuid_clear (unbox-puuid uuid))
    146        uuid) )
     151  (and
     152    (%uuid? uuid)
     153    (uuid_clear (unbox-puuid uuid))
     154    uuid) )
    147155
    148156(define (uuid-copy uuid-old)
    149   (and (%uuid? uuid-old)
    150        (let ((uuid (new-uuid)))
    151          (uuid_copy (unbox-puuid uuid) (unbox-puuid uuid-old))
    152          uuid)) )
     157  (and
     158    (%uuid? uuid-old)
     159    (let ((uuid (new-uuid)))
     160      (uuid_copy (unbox-puuid uuid) (unbox-puuid uuid-old))
     161      uuid)) )
    153162
    154163(define (uuid-generate #!optional (variant #f))
     
    156165    (case variant
    157166      ((#f)
    158        (uuid_generate (unbox-puuid uuid)))
     167        (uuid_generate (unbox-puuid uuid)))
    159168      ((V4 random)
    160        (uuid_generate_random (unbox-puuid uuid)))
     169        (uuid_generate_random (unbox-puuid uuid)))
    161170      ((V1 time)
    162        (uuid_generate_time (unbox-puuid uuid)))
     171        (uuid_generate_time (unbox-puuid uuid)))
    163172      (else
    164        (##sys#signal-hook #:type-error 'uuid-generate
    165                           "bad argument type - invalid variant" variant)))
     173        (##sys#signal-hook #:type-error 'uuid-generate
     174                            "bad argument type - invalid variant" variant)))
    166175    uuid ) )
    167176
    168177(define (make-uuid . args)
    169   (if (null? args) (uuid-clear! (new-uuid))
    170       (apply uuid-generate args) ) )
     178  (if (null? args)
     179    (uuid-clear! (new-uuid))
     180    (apply uuid-generate args) ) )
    171181
    172182(define (uuid-parse uuid-text)
    173183  (unless (or (string? uuid-text) (symbol? uuid-text))
    174184    (##sys#signal-hook #:type-error 'uuid-parse
    175                        "bad argument type - not a string or symbol" uuid-text))
     185      "bad argument type - not a string or symbol" uuid-text))
    176186  (when (symbol? uuid-text) (set! uuid-text (symbol->string uuid-text)))
    177187  (let ((uuid (new-uuid)))
    178     (and (zero? (uuid_parse uuid-text (unbox-puuid uuid)))
    179          uuid) ) )
     188    (and
     189      (zero? (uuid_parse uuid-text (unbox-puuid uuid)))
     190      uuid) ) )
    180191
    181192(define (uuid-unparse uuid #!optional (kase #f))
    182   (and (%uuid? uuid)
    183        (let* ((uuid-text (make-string (add1 length-uuid-string)))
    184               (puuid-text (make-locative uuid-text)))
    185          (case kase
    186            ((upper)
    187             (uuid_unparse_upper (unbox-puuid uuid) puuid-text))
    188            ((lower)
    189             (uuid_unparse_lower (unbox-puuid uuid) puuid-text))
    190            ((#f)
    191             (uuid_unparse (unbox-puuid uuid) puuid-text))
    192            (else
    193             (##sys#signal-hook #:type-error 'uuid-generate
    194                                "bad argument type - invalid case" kase)))
    195          (substring uuid-text 0 length-uuid-string) ) ) )
     193  (and
     194    (%uuid? uuid)
     195    (let* (
     196      (uuid-text (make-string (add1 length-uuid-string)))
     197      (puuid-text (make-locative uuid-text)) )
     198      (case kase
     199        ((upper)
     200          (uuid_unparse_upper (unbox-puuid uuid) puuid-text))
     201        ((lower)
     202          (uuid_unparse_lower (unbox-puuid uuid) puuid-text))
     203        ((#f)
     204          (uuid_unparse (unbox-puuid uuid) puuid-text))
     205        (else
     206          (##sys#signal-hook #:type-error 'uuid-generate
     207            "bad argument type - invalid case" kase)) )
     208      (substring uuid-text 0 length-uuid-string) ) ) )
    196209
    197210(define (string->uuid str)
  • release/4/uuid-lib/trunk/uuid-lib.setup

    r27266 r35421  
    1 ;;;; uuid-lib.setup  -*- Hen -*-
     1;;;; uuid-lib.setup
    22
    33(use setup-helper-mod)
     
    66
    77(define compile-options `(
    8     -local
    9     -scrutinize
    10     -fixnum-arithmetic
    11     -optimize-level 3 -debug-level 1
    12     -no-procedure-checks
     8  -local
     9  -scrutinize
     10  -optimize-level 3 -debug-level 1
     11  -no-procedure-checks
    1312  ,@(cond-expand
    14       (linux    '(-L -luuid) )
    15       (else     '() ) ) ) )
     13    (linux    '(-L -luuid) )
     14    (else     '() ) ) ) )
    1615
    17 (setup-shared-extension-module 'uuid-lib (extension-version "1.4.1")
     16(setup-shared-extension-module 'uuid-lib (extension-version "1.5.0")
    1817  #:types? #t
    1918  #:inline? #t
Note: See TracChangeset for help on using the changeset viewer.