Changeset 35230 in project


Ignore:
Timestamp:
03/04/18 04:56:20 (10 months ago)
Author:
kon
Message:

use csi+csc test runner, expose pack-integer, add types, more runtime checks, add tests

Location:
release/4/blob-utils/trunk
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/blob-utils/trunk/blob-hexadecimal.scm

    r34149 r35230  
    77  blob->hex)
    88
    9 (import scheme)
    10 
    11 (import chicken foreign)
    12 
    13 (import
     9(import scheme chicken foreign)
     10(use
    1411  (only to-hex blob_to_hex)
    1512  (only type-checks check-natural-fixnum check-blob))
    16 (require-library to-hex type-checks)
    1713
    1814(declare
     
    2319
    2420(: blob->hex (blob #!optional fixnum (or fixnum boolean) -> string))
     21;
    2522(define (blob->hex blb #!optional (start 0) (end #f))
    2623  (check-blob 'blob->hex blb)
  • release/4/blob-utils/trunk/blob-set-int.scm

    r34149 r35230  
    1717  *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
    1818
    19 (import scheme)
    20 
    21 (import chicken foreign)
    22 
    23 (import (only type-checks check-natural-fixnum check-blob check-fixnum check-integer))
    24 (require-library type-checks)
    25 
    26 (: *blob-set-u8! ((or blob string) number fixnum -> undefined))
    27 (: *blob-set-u16-le! ((or blob string) number fixnum -> undefined))
    28 (: *blob-set-u32-le! ((or blob string) number fixnum -> undefined))
    29 (: *blob-set-u64-le! ((or blob string) number fixnum -> undefined))
    30 (: *blob-set-u16-be! ((or blob string) number fixnum -> undefined))
    31 (: *blob-set-u32-be! ((or blob string) number fixnum -> undefined))
    32 (: *blob-set-u64-be! ((or blob string) number fixnum -> undefined))
    33 
    34 (: blob-set-u8! (blob fixnum #!optional fixnum -> undefined))
    35 (: blob-set-u16-le! (blob fixnum #!optional fixnum -> undefined))
    36 (: blob-set-u32-le! (blob number #!optional fixnum -> undefined))
    37 (: blob-set-u64-le! (blob number #!optional fixnum -> undefined))
    38 (: blob-set-u16-be! (blob fixnum #!optional fixnum -> undefined))
    39 (: blob-set-u32-be! (blob number #!optional fixnum -> undefined))
    40 (: blob-set-u64-be! (blob number #!optional fixnum -> undefined))
     19(import scheme chicken foreign)
     20(use
     21  (only type-checks
     22    check-natural-fixnum check-fixnum check-integer
     23    check-blob))
    4124
    4225;;; Only Blob Bytevector, No Argument Checking
    4326
     27(: *blob-set-u8! ((or blob string) number fixnum -> void))
     28;
    4429(define *blob-set-u8!
    4530  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off))
    46 #<<EOS
    47     ((uint8_t *)bv)[off] = (uint8_t)(u32 & 0xff);
    48 EOS
    49         ))
    50 
     31    "((uint8_t *)bv)[off] = (uint8_t)(u32 & 0xff);\n"))
     32
     33(: *blob-set-u16-le! ((or blob string) number fixnum -> void))
     34;
    5135(define *blob-set-u16-le!
    5236  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off))
    53 #<<EOS
    54     ((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
    55     ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);
    56 EOS
    57         ))
    58 
     37    "((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
     38    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);\n"))
     39
     40(: *blob-set-u32-le! ((or blob string) number fixnum -> void))
     41;
    5942(define *blob-set-u16-be!
    6043  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off))
    61 #<<EOS
    62     ((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 8) & 0xff);
    63     ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);
    64 EOS
    65         ))
    66 
     44    "((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 8) & 0xff);
     45    ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);\n"))
     46
     47(: *blob-set-u64-le! ((or blob string) number fixnum -> void))
     48;
    6749(define *blob-set-u32-le!
    6850  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off))
    69 #<<EOS
    70     ((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
     51    "((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
    7152    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);
    7253    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 16) & 0xff);
    73     ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 24) & 0xff);
    74 EOS
    75         ))
    76 
     54    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 24) & 0xff);\n"))
     55
     56(: *blob-set-u16-be! ((or blob string) number fixnum -> void))
     57;
    7758(define *blob-set-u32-be!
    7859  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off))
    79 #<<EOS
    80     ((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 24) & 0xff);
     60    "((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 24) & 0xff);
    8161    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 16) & 0xff);
    8262    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);
    83     ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);
    84 EOS
    85         ))
    86 
     63    ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);\n"))
     64
     65(: *blob-set-u32-be! ((or blob string) number fixnum -> void))
     66;
    8767(define *blob-set-u64-le!
    8868  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer64 u64) (int off))
    89 #<<EOS
    90     ((uint8_t *)bv)[off]   = (uint8_t)(u64 & 0xff);
     69    "((uint8_t *)bv)[off]   = (uint8_t)(u64 & 0xff);
    9170    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 8) & 0xff);
    9271    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 16) & 0xff);
     
    9574                ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 40) & 0xff);
    9675                ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 48) & 0xff);
    97                 ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 56) & 0xff);
    98 EOS
    99         ))
    100 
     76                ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 56) & 0xff);\n"))
     77
     78(: *blob-set-u64-be! ((or blob string) number fixnum -> void))
     79;
    10180(define *blob-set-u64-be!
    10281  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer64 u64) (int off))
    103 #<<EOS
    104     ((uint8_t *)bv)[off]   = (uint8_t)((u64 >> 56) & 0xff);
     82    "((uint8_t *)bv)[off]   = (uint8_t)((u64 >> 56) & 0xff);
    10583    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 48) & 0xff);
    10684    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 40) & 0xff);
     
    10987    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 16) & 0xff);
    11088    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 8) & 0xff);
    111     ((uint8_t *)bv)[++off] = (uint8_t)(u64 & 0xff);
    112 EOS
    113         ))
     89    ((uint8_t *)bv)[++off] = (uint8_t)(u64 & 0xff);\n"))
    11490
    11591;;; Only Blob Bytevector
     
    11793;; 8
    11894
     95(: blob-set-u8! (blob fixnum #!optional fixnum -> void))
     96;
    11997(define (blob-set-u8! blb uint #!optional (off 0))
    12098  (*blob-set-u8!
     
    125103;; Little Endian 16, 32, & 64
    126104
     105(: blob-set-u16-le! (blob fixnum #!optional fixnum -> void))
     106;
    127107(define (blob-set-u16-le! blb uint #!optional (off 0))
    128108  (*blob-set-u16-le!
     
    131111    (check-natural-fixnum 'blob-set-u16-le! off 'offset)) )
    132112
     113(: blob-set-u32-le! (blob number #!optional fixnum -> void))
     114;
    133115(define (blob-set-u32-le! blb uint #!optional (off 0))
    134116  (*blob-set-u32-le!
     
    137119    (check-natural-fixnum 'blob-set-u32-le! off 'offset)) )
    138120
     121(: blob-set-u64-le! (blob number #!optional fixnum -> void))
     122;
    139123(define (blob-set-u64-le! blb uint #!optional (off 0))
    140124  (*blob-set-u64-le!
     
    145129;; Big Endian 16, 32, & 64
    146130
     131(: blob-set-u16-be! (blob fixnum #!optional fixnum -> void))
     132;
    147133(define (blob-set-u16-be! blb uint #!optional (off 0))
    148134  (*blob-set-u16-be!
     
    151137    (check-natural-fixnum 'blob-set-u16-be! off 'offset)) )
    152138
     139(: blob-set-u32-be! (blob number #!optional fixnum -> void))
     140;
    153141(define (blob-set-u32-be! blb uint #!optional (off 0))
    154142  (*blob-set-u32-be!
     
    157145    (check-natural-fixnum 'blob-set-u32-be! off 'offset)) )
    158146
     147(: blob-set-u64-be! (blob number #!optional fixnum -> void))
     148;
    159149(define (blob-set-u64-be! blb uint #!optional (off 0))
    160150  (*blob-set-u64-be!
     
    162152    (check-integer 'blob-set-u64-be! uint)
    163153    (check-natural-fixnum 'blob-set-u64-be! off 'offset)) )
     154
     155) ;module blob-set-int
     156
    164157
    165158#| ;Useful API?
     
    242235                          (blob-set-u64-be! bv uint idx) ) ) ) )
    243236|#
    244 
    245 ) ;module blob-set-int
  • release/4/blob-utils/trunk/blob-utils.meta

    r34149 r35230  
    88 (synopsis "Blob Utilities")
    99 (depends
    10         (setup-helper "1.5.2")
    1110        ;to-hex
    12         (string-utils "1.2.2"))
     11        (string-utils "1.2.2")
     12        (check-errors "2.1.0")
     13        (setup-helper "1.5.2"))
    1314 (test-depends test)
    1415 (files
    15         "blob-set-int.scm"
    16         "blob-hexadecimal.scm"
    17         "blob-utils.setup"
    18         "tests/run.scm"
    19         "blob-utils.meta") )
     16        "blob-utils.meta" "blob-utils.setup"
     17        "blob-set-int.scm" "blob-hexadecimal.scm"
     18        "tests/run.scm" "tests/blob-utils-test.scm") )
  • release/4/blob-utils/trunk/blob-utils.setup

    r34149 r35230  
    55(verify-extension-name "blob-utils")
    66
    7 (setup-shared+static-extension-module 'blob-set-int (extension-version "1.0.4")
     7(setup-shared+static-extension-module 'blob-set-int (extension-version "1.1.0")
    88  #:types? #t
    99  #:inline? #t
     
    1212    -no-procedure-checks -no-argc-checks -no-bound-checks))
    1313
    14 (setup-shared-extension-module 'blob-hexadecimal (extension-version "1.0.4")
     14(setup-shared-extension-module 'blob-hexadecimal (extension-version "1.1.0")
    1515  #:types? #t
    1616  #:inline? #t
     
    1919    -no-procedure-checks))
    2020
    21 #;
    22 (setup-shared-extension-module 'pack-integer (extension-version "1.0.4")
     21(setup-shared-extension-module 'pack-integer (extension-version "1.1.0")
    2322  #:types? #t
    2423  #:inline? #t
     
    2726    -no-procedure-checks))
    2827
    29 (install-extension-tag 'blob-utils (extension-version "1.0.4"))
     28(install-extension-tag 'blob-utils (extension-version "1.1.0"))
  • release/4/blob-utils/trunk/pack-integer.scm

    r34149 r35230  
    55
    66;; Issues
     7
     8(module pack-integer
     9
     10(;export
     11  pack-u8
     12  pack-u16
     13  pack-u32
     14  pack-u64
     15  pack-integer)
     16
     17(import scheme chicken foreign)
     18(use
     19  (only lolevel number-of-bytes)
     20  (only srfi-4
     21    make-u8vector u8vector? u8vector-length u8vector-set!)
     22  (only type-checks
     23    check-blob check-integer check-natural-fixnum
     24    define-check+error-type)
     25  (only type-errors
     26    error-argument-type
     27    error-half-closed-interval
     28    define-error-type)
     29  blob-set-int)
     30
     31;;;
    732
    833#>
     
    6287<#
    6388
    64 (module pack-integer
    65 
    66 (;export
    67   pack-u8
    68   pack-u16
    69   pack-u32
    70   pack-u64
    71   pack-integer)
    72 
    73 (import scheme)
    74 
    75 (import chicken foreign)
    76 
    77 (import
    78   (only type-checks check-blob check-integer)
    79   (only type-errors error-argument-type))
    80 (require-library type-checks type-errors)
     89(define (fxzero? x)
     90  (fx= 0 x) )
    8191
    8292;;; Integer Packing Utilities
     
    90100;; Pack an 8 bit integer
    91101
    92 (define-inline (pack-u8/u8vector! u8vec n i)
     102(define-inline (pack-u8-with-u8vector! u8vec n i)
    93103  (u8vector-set! u8vec i n)
    94104  u8vec )
    95105
    96 (define-inline (pack-u8/bytevector! bv n i)
     106(define-inline (pack-u8-with-bytevector! bv n i)
    97107  (##core#inline "C_setbyte" bv i n) ;(bytevector-set! bv i n)
    98108  bv )
    99109
    100 (define-inline (pack-u8/blob! blb n i)
    101   (pack-u8/bytevector! blb n i) )
    102 
    103 (define-inline (pack-u8/string! str n i)
    104   (pack-u8/bytevector! str n i) )
     110(define-inline (pack-u8-with-blob! blb n i)
     111  (pack-u8-with-bytevector! blb n i) )
     112
     113(define-inline (pack-u8-with-string! str n i)
     114  (pack-u8-with-bytevector! str n i) )
    105115
    106116; Pack a 16, 32, or 64 bit integer with endian order
    107117
    108 (define-inline (pack-u64/u8vector! u8vec n size direction start)
     118(define-inline (pack-u64-with-u8vector! u8vec n size direction start)
    109119  ((foreign-lambda void "pack_uint64" nonnull-u8vector unsigned-integer64 int int int)
    110120     u8vec n size direction start)
    111121  u8vec )
    112122
    113 (define-inline (pack-u64/bytevector! bv n size direction start)
     123(define-inline (pack-u64-with-bytevector! bv n size direction start)
    114124  ((foreign-lambda void "pack_uint64" nonnull-scheme-pointer unsigned-integer64 int int int)
    115125    bv n size direction start)
    116126  bv )
    117127
    118 (define-inline (pack-u64/blob! blb n size direction start)
    119   (pack-u64/bytevector! blb n size direction start) )
    120 
    121 (define-inline (pack-u64/string! str n size direction start)
    122   (pack-u64/bytevector! str n size direction start) )
    123 
    124 ;;
    125 
    126 (define (byte-order? obj)
    127   (and
    128     (memq obj '(big-endian be big little-endian le little))
    129     #t) )
    130 
    131 (define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
    132 
    133 #; ;UNUSED
    134 (define (direction->byte-order n)
    135   (if (negative? n)
    136     'big-endian
    137     'little-endian ) )
     128(define-inline (pack-u64-with-blob! blb n size direction start)
     129  (pack-u64-with-bytevector! blb n size direction start) )
     130
     131(define-inline (pack-u64-with-string! str n size direction start)
     132  (pack-u64-with-bytevector! str n size direction start) )
     133
     134;;
     135
     136(define-constant MAX-BV-LEN 16777215) ;2^24-1 is the maximum length of a bytevector
    138137
    139138(define-inline (byte-order->direction order)
     
    142141      -1 )
    143142    ((little-endian le little)
    144       1 ) ) )
    145 
    146 (define-error-type byte-buffer "u8vector, blob, string or symbol in {u8vector blob string}" )
     143      1 )
     144    (else
     145      0 ) ) )
    147146
    148147(define-inline (check-byte-size loc obj)
     
    150149    (error-argument-type loc obj "integer in {1 2 4 8}" 'size) )
    151150  obj )
    152 
    153 (define-constant MAX-BV-LEN 16777215) ; 2^24-1 is the maximum length of a bytevector
    154151
    155152(define-inline (check-byte-buffer-size loc dessiz actsiz)
     
    159156  actsiz )
    160157
    161 (define (ensure-byte-buffer loc size bufsel start)
    162   (let ((need-size (fx+ start size)))
    163     ; Cases ordered by a guess of probability
     158(define-type byte-order symbol)
     159
     160(: byte-order? (* -> boolean : byte-order))
     161;
     162(define (byte-order? obj)
     163  (not (fxzero? (byte-order->direction obj))) )
     164
     165(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
     166
     167(define-type buffer-type (or string blob u8vector))
     168
     169(define-error-type byte-buffer-kind "symbol in {u8vector blob string}")
     170(define-error-type byte-buffer "u8vector, blob, string")
     171
     172(: ensure-byte-buffer (symbol fixnum (or symbol buffer-type) fixnum -> symbol buffer-type))
     173;
     174(define (ensure-byte-buffer loc size kind start)
     175  (check-natural-fixnum loc size 'size)
     176  (check-natural-fixnum loc start 'start)
     177  (let (
     178    (buffer-size (fx+ start size)) )
     179    ;cases ordered by a guess of probability
    164180    (cond
    165       ((symbol? bufsel)
    166         (case bufsel
     181      ((symbol? kind)
     182        (case kind
    167183          ((string)
    168             (values 'string (make-string need-size)) )
     184            (values 'string (make-string buffer-size)) )
    169185          ((blob)
    170             (values 'blob (make-blob need-size)) )
     186            (values 'blob (make-blob buffer-size)) )
    171187          ((u8vector)
    172             (values 'u8vector (make-u8vector need-size)) )
     188            (values 'u8vector (make-u8vector buffer-size)) )
    173189          (else
    174             (error-byte-buffer loc bufsel) ) ) )
    175       ((string? bufsel)
    176         (check-byte-buffer-size loc need-size (number-of-bytes bufsel))
    177         (values 'string bufsel) )
    178       ((blob? bufsel)
    179         (check-byte-buffer-size loc need-size (number-of-bytes bufsel))
    180         (values 'blob bufsel) )
    181       ((u8vector? bufsel)
    182         (check-byte-buffer-size loc need-size (u8vector-length bufsel))
    183         (values 'u8vector bufsel) )
     190            (error-byte-buffer-kind loc kind) ) ) )
     191      ((string? kind)
     192        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
     193        (values 'string kind) )
     194      ((blob? kind)
     195        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
     196        (values 'blob kind) )
     197      ((u8vector? kind)
     198        (check-byte-buffer-size loc buffer-size (u8vector-length kind))
     199        (values 'u8vector kind) )
    184200      (else
    185         (error-byte-buffer loc bufsel) ) ) ) )
    186 
    187 ;;
    188 
    189 (define (*pack-u8 loc n bufsel start)
     201        (error-byte-buffer loc kind) ) ) ) )
     202
     203;;
     204
     205(: *pack-u8 (symbol fixnum (or symbol buffer-type) fixnum -> buffer-type))
     206;
     207(define (*pack-u8 loc n kind start)
    190208  (check-integer loc n)
    191   (receive (typ obj) (ensure-byte-buffer loc 1 bufsel start)
    192     (case typ
     209  (let-values (
     210    ((knd obj) (ensure-byte-buffer loc 1 kind start)) )
     211    (case knd
    193212      ((string)
    194         (pack-u8/string! obj n start) )
     213        (pack-u8-with-string! obj n start) )
    195214      ((blob)
    196         (pack-u8/blob! obj n start) )
     215        (pack-u8-with-blob! obj n start) )
    197216      ((u8vector)
    198         (pack-u8/u8vector! obj n start) ) )
     217        (pack-u8-with-u8vector! obj n start) ) )
    199218    obj ) )
    200219
    201 (define (pack-u8 n #!key (bufsel 'string) (start 0))
    202   (*pack-u8 'pack-u8 n bufsel start) )
    203 
    204 ;;
    205 
    206 (define (*pack-integer loc n bufsel size order start)
     220(: pack-u8 (fixnum #!rest -> buffer-type))
     221;
     222(define (pack-u8 n #!key (kind 'string) (start 0))
     223  (*pack-u8 'pack-u8 n kind start) )
     224
     225;;
     226
     227(: *pack-integer (symbol number (or symbol buffer-type) fixnum symbol fixnum -> buffer-type))
     228;
     229(define (*pack-integer loc n kind size order start)
    207230  (check-integer loc n)
    208231  (check-byte-order loc order)
    209   (receive (typ obj) (ensure-byte-buffer loc size bufsel start)
    210     (let ((direction (byte-order->direction order)))
    211       (case typ
     232  (let-values (
     233    ((knd obj) (ensure-byte-buffer loc size kind start)) )
     234    (let (
     235      (direction (byte-order->direction order)) )
     236      (case knd
    212237        ((string)
    213           (pack-u64/string! obj n size direction start) )
     238          (pack-u64-with-string! obj n size direction start) )
    214239        ((blob)
    215           (pack-u64/blob! obj n size direction start) )
     240          (pack-u64-with-blob! obj n size direction start) )
    216241        ((u8vector)
    217           (pack-u64/u8vector! obj n size direction start) ) ) )
     242          (pack-u64-with-u8vector! obj n size direction start) ) ) )
    218243    obj ) )
    219244
    220245;;
    221246
    222 (define (pack-u16 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
    223   (*pack-integer 'pack-u16 n bufsel 2 order start) )
    224 
    225 ;;
    226 
    227 (define (pack-u32 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
    228   (*pack-integer 'pack-u32 n bufsel 4 order start) )
    229 
    230 ;;
    231 
    232 (define (pack-u64 n #!key (bufsel 'string) (start 0) (order (machine-byte-order)))
    233   (*pack-integer 'pack-u64 n bufsel 8 order start) )
    234 
    235 ;;
    236 
    237 (define (pack-integer n #!key (bufsel 'string) (start 0) (order (machine-byte-order)) (size 4))
     247(: pack-u16 (fixnum #!rest -> buffer-type))
     248;
     249(define (pack-u16 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
     250  (*pack-integer 'pack-u16 n kind 2 order start) )
     251
     252;;
     253
     254(: pack-u32 (number #!rest -> buffer-type))
     255;
     256(define (pack-u32 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
     257  (*pack-integer 'pack-u32 n kind 4 order start) )
     258
     259;;
     260
     261(: pack-u64 (number #!rest -> buffer-type))
     262;
     263(define (pack-u64 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
     264  (*pack-integer 'pack-u64 n kind 8 order start) )
     265
     266;;
     267
     268(: pack-integer (number #!rest -> buffer-type))
     269;
     270(define (pack-integer n #!key (kind 'string) (start 0) (order (machine-byte-order)) (size 4))
    238271  (check-byte-size 'pack-integer size)
    239272  (if (fx= 1 size)
    240     (*blob-set-u8! 'pack-integer n bufsel start)
    241     (*pack-integer 'pack-integer n bufsel size order start) ) )
     273    (let-values (
     274      ((knd obj) (ensure-byte-buffer 'pack-integer size kind start)) )
     275      (*blob-set-u8! n obj start) )
     276    (*pack-integer 'pack-integer n kind size order start) ) )
    242277
    243278) ;module pack-integer
  • release/4/blob-utils/trunk/tests/run.scm

    r34149 r35230  
    1 (use test)
    21
    3 (use blob-hexadecimal)
     2(define EGG-NAME "blob-utils")
    43
    5 (test-begin "Blob Utils")
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    65
    7 (test-group "-> Hex"
    8         (test "414243444546" (blob->hex (string->blob "ABCDEF")))
    9         (test "4243444546" (blob->hex (string->blob "ABCDEF") 1))
    10         (test "4243" (blob->hex (string->blob "ABCDEF") 1 3))
    11 )
     6(use files)
    127
    13 (use blob-set-int)
     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")
    1410
    15 #;
    16 (test-group "Set Int"
    17 )
     11(define *args* (argv))
    1812
    19 (test-end)
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    2015
    21 (test-exit)
     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") ) ) )
     24
     25;;;
     26
     27(set! EGG-NAME (egg-name))
     28
     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)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.