Changeset 35422 in project


Ignore:
Timestamp:
04/22/18 02:12:27 (4 months ago)
Author:
kon
Message:

runtime error check test is eval only, add types, use fx, add type error

Location:
release/4/uuid-lib/trunk
Files:
2 edited

Legend:

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

    r35421 r35422  
    1 ;;;; uuid-lib-test.scm  -*- Hen -*-
     1;;;; uuid-lib-test.scm
    22
    33(use test)
     
    4242      (uuid=? tuuid (uuid-parse (uuid-unparse tuuid 'lower)))))
    4343
    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))))
     44  ;checks types which is the compiler's job
     45  (eval-when (eval)
    4846
    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))))
     47    (test "Error in generate caught correctly"
     48      "bad argument type - invalid variant"
     49      (condition-case (uuid-generate 2)
     50        (v () ((condition-property-accessor 'exn 'message) v))))
     51
     52    (test "Error in unparse caught correctly"
     53      "bad argument type - invalid case"
     54      (condition-case (uuid-unparse (uuid-generate) 2)
     55        (v () ((condition-property-accessor 'exn 'message) v)))) )
    5356
    5457  (test "Finalizer"
  • release/4/uuid-lib/trunk/uuid-lib.scm

    r35421 r35422  
    3232;;
    3333
     34(define (fxzero? x)
     35  (fx= 0 x) )
     36
     37(define (fxnegative? x)
     38  (fx< x 0) )
     39
     40(define (fxpositive? x)
     41  (fx> x 0) )
     42
     43;;
     44
    3445#>
    3546#include <uuid/uuid.h>
     
    7586;;
    7687
     88(define-type boxed-uuid pointer)
     89
    7790(define-inline (unbox-puuid boxed-puuid)
    7891  boxed-puuid )
     
    95108;;
    96109
    97 (define (uuid? uuid)
    98   (%uuid? uuid) )
    99 
    100 (define (uuid-null? uuid)
     110(: uuid? (* -> boolean : boxed-uuid))
     111;
     112(define (uuid? obj)
     113  (%uuid? obj) )
     114
     115(: check-uuid (symbol * --> boxed-uuid))
     116;
     117(define (check-uuid loc obj)
     118  (unless (%uuid? obj)
     119    (##sys#signal-hook
     120      #:type-error 'uuid-compare'
     121      "bad argument type - not a uuid" obj))
     122  obj )
     123
     124(: uuid-null? (* --> boolean))
     125;
     126(define (uuid-null? obj)
    101127  (and
    102     (%uuid? uuid)
    103     (uuid_is_null (unbox-puuid uuid))) )
    104 
     128    (%uuid? obj)
     129    (uuid_is_null (unbox-puuid obj))) )
     130
     131(: uuid-compare (boxed-uuid boxed-uuid --> fixnum))
     132;
    105133(define (uuid-compare uuid1 uuid2)
    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) ) ) ) )
    114 
     134  (let (
     135    (cmp
     136      (%uuid-compare
     137        (check-uuid 'uuid-compare uuid1)
     138        (check-uuid 'uuid-compare uuid2))) )
     139    (cond
     140      ((fxnegative? cmp)  -1)
     141      ((fxzero? cmp)      0)
     142      (else               1) ) ) )
     143
     144(: uuid=? (boxed-uuid boxed-uuid --> boolean))
     145;
    115146(define (uuid=? uuid1 uuid2)
    116   (and
    117     (%uuid? uuid1)
    118        (%uuid? uuid2)
    119        (zero? (%uuid-compare uuid1 uuid2))) )
    120 
     147  (fxzero? (%uuid-compare uuid1 uuid2)) )
     148
     149(: uuid<>? (boxed-uuid boxed-uuid --> boolean))
     150;
    121151(define (uuid<>? uuid1 uuid2)
    122152  (not (uuid=? uuid1 uuid2)) )
    123153
     154(: uuid<? (boxed-uuid boxed-uuid --> boolean))
     155;
    124156(define (uuid<? uuid1 uuid2)
     157  (fxnegative? (%uuid-compare uuid1 uuid2)) )
     158
     159(: uuid>? (boxed-uuid boxed-uuid --> boolean))
     160;
     161(define (uuid>? uuid1 uuid2)
     162  (fxpositive? (%uuid-compare uuid1 uuid2)) )
     163
     164(: uuid<=? (boxed-uuid boxed-uuid --> boolean))
     165;
     166(define (uuid<=? uuid1 uuid2)
     167  (let (
     168    (comp (%uuid-compare uuid1 uuid2)) )
     169    (or (fxzero? comp) (fxnegative? comp))) )
     170
     171(: uuid>=? (boxed-uuid boxed-uuid --> boolean))
     172;
     173(define (uuid>=? uuid1 uuid2)
     174  (let (
     175    (comp (%uuid-compare uuid1 uuid2)) )
     176    (or (fxzero? comp) (fxpositive? comp))) )
     177
     178(: uuid-clear! (boxed-uuid -> boxed-uuid))
     179;
     180(define (uuid-clear! uuid)
     181  (check-uuid 'uuid-clear! uuid)
    125182  (and
    126     (%uuid? uuid1)
    127     (%uuid? uuid2)
    128     (negative? (%uuid-compare uuid1 uuid2))) )
    129 
    130 (define (uuid>? uuid1 uuid2)
    131   (and
    132     (%uuid? uuid1)
    133     (%uuid? uuid2)
    134     (positive? (%uuid-compare uuid1 uuid2))) )
    135 
    136 (define (uuid<=? uuid1 uuid2)
    137   (and
    138     (%uuid? uuid1)
    139     (%uuid? uuid2)
    140     (let ((comp (%uuid-compare uuid1 uuid2)))
    141       (or (zero? comp) (negative? comp)))) )
    142 
    143 (define (uuid>=? uuid1 uuid2)
    144   (and
    145     (%uuid? uuid1)
    146     (%uuid? uuid2)
    147     (let ((comp (%uuid-compare uuid1 uuid2)))
    148       (or (zero? comp) (positive? comp)))) )
    149 
    150 (define (uuid-clear! uuid)
    151   (and
    152     (%uuid? uuid)
    153183    (uuid_clear (unbox-puuid uuid))
    154184    uuid) )
    155185
    156 (define (uuid-copy uuid-old)
    157   (and
    158     (%uuid? uuid-old)
    159     (let ((uuid (new-uuid)))
    160       (uuid_copy (unbox-puuid uuid) (unbox-puuid uuid-old))
    161       uuid)) )
    162 
     186(: uuid-copy (boxed-uuid --> boxed-uuid))
     187;
     188(define (uuid-copy old-uuid)
     189  (check-uuid 'uuid-copy old-uuid)
     190  (let (
     191    (uuid (new-uuid)) )
     192    (uuid_copy (unbox-puuid uuid) (unbox-puuid old-uuid))
     193    uuid) )
     194
     195(: uuid-generate (#!optional (or boolean symbol) --> boxed-uuid))
     196;
    163197(define (uuid-generate #!optional (variant #f))
    164   (let ((uuid (new-uuid)))
     198  (let (
     199    (uuid (new-uuid)) )
    165200    (case variant
    166201      ((#f)
     
    175210    uuid ) )
    176211
     212(: make-uuid (#!optional (or boolean symbol) --> boxed-uuid))
     213;
    177214(define (make-uuid . args)
    178215  (if (null? args)
     
    180217    (apply uuid-generate args) ) )
    181218
     219(: uuid-parse ((or string symbol) --> boxed-uuid))
     220;
    182221(define (uuid-parse uuid-text)
    183222  (unless (or (string? uuid-text) (symbol? uuid-text))
    184223    (##sys#signal-hook #:type-error 'uuid-parse
    185224      "bad argument type - not a string or symbol" uuid-text))
    186   (when (symbol? uuid-text) (set! uuid-text (symbol->string uuid-text)))
    187   (let ((uuid (new-uuid)))
     225  (let* (
     226    (uuid-text
     227      (if (symbol? uuid-text) (symbol->string uuid-text) uuid-text))
     228    (uuid
     229      (new-uuid)) )
    188230    (and
    189231      (zero? (uuid_parse uuid-text (unbox-puuid uuid)))
    190232      uuid) ) )
    191233
     234(: uuid-unparse (boxed-uuid #!optional (or boolean symbol) --> string))
     235;
    192236(define (uuid-unparse uuid #!optional (kase #f))
    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) ) ) )
    209 
     237  (check-uuid 'uuid-unparse uuid)
     238  (let* (
     239    (uuid-text (make-string (add1 length-uuid-string)))
     240    (puuid-text (make-locative uuid-text)) )
     241    (case kase
     242      ((upper)
     243        (uuid_unparse_upper (unbox-puuid uuid) puuid-text))
     244      ((lower)
     245        (uuid_unparse_lower (unbox-puuid uuid) puuid-text))
     246      ((#f)
     247        (uuid_unparse (unbox-puuid uuid) puuid-text))
     248      (else
     249        (##sys#signal-hook #:type-error 'uuid-generate
     250          "bad argument type - invalid case" kase)) )
     251    (substring uuid-text 0 length-uuid-string) ) )
     252
     253(: string->uuid (string --> boxed-uuid))
     254;
    210255(define (string->uuid str)
    211256  (uuid-parse str) )
    212257
     258(: uuid->string (boxed-uuid --> string))
     259;
    213260(define (uuid->string uuid)
    214261  (uuid-unparse uuid 'lower) )
Note: See TracChangeset for help on using the changeset viewer.