Changeset 34149 in project


Ignore:
Timestamp:
06/01/17 04:35:03 (4 weeks ago)
Author:
kon
Message:

re-flow

Location:
release/4/blob-utils
Files:
12 edited
1 copied

Legend:

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

    r27987 r34149  
    44(module blob-hexadecimal
    55
    6   (;export
    7     blob->hex)
     6(;export
     7  blob->hex)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only to-hex blob_to_hex)
    13     (only type-checks check-natural-fixnum check-blob))
     9(import scheme)
    1410
    15   (require-library to-hex type-checks)
     11(import chicken foreign)
    1612
    17   (declare
    18     (bound-to-procedure
    19       ##sys#signal-hook))
     13(import
     14  (only to-hex blob_to_hex)
     15  (only type-checks check-natural-fixnum check-blob))
     16(require-library to-hex type-checks)
    2017
    21   (declare
    22     (type
    23       (blob->hex (blob #!optional fixnum (or fixnum boolean) -> string)) ) )
     18(declare
     19  (bound-to-procedure
     20    ##sys#signal-hook))
    2421
    2522;;
    2623
     24(: blob->hex (blob #!optional fixnum (or fixnum boolean) -> string))
    2725(define (blob->hex blb #!optional (start 0) (end #f))
    2826  (check-blob 'blob->hex blb)
     
    3129  (let ((end (or end (blob-size blb))))
    3230    (unless (<= start end)
    33       (##sys#signal-hook #:bounds-error 'blob->hex
    34                          "illegal subvector specification" start end))
     31      (##sys#signal-hook
     32        #:bounds-error 'blob->hex
     33        "illegal subvector specification" start end))
    3534    (let ((len (fx- end start)))
    36       (if (fx= 0 len) ""
     35      (if (fx= 0 len)
     36        ""
    3737        (let ((res (make-string (fx* len 2))))
    3838          (blob_to_hex res blb start len)
  • release/4/blob-utils/tags/1.0.4/blob-set-int.scm

    r27996 r34149  
    88(module blob-set-int
    99
    10   (;export
    11     blob-set-u8!
    12     blob-set-u16-le! blob-set-u32-le! blob-set-u64-le!
    13     blob-set-u16-be! blob-set-u32-be! blob-set-u64-be!
    14     ;
    15     *blob-set-u8!
    16     *blob-set-u16-le! *blob-set-u32-le! *blob-set-u64-le!
    17     *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
    18 
    19   (import
    20     scheme
    21     chicken
    22     foreign
    23     (only type-checks check-natural-fixnum check-blob check-fixnum check-integer))
    24 
    25   (require-library
    26     type-checks)
    27 
    28   (declare
    29     (type
    30       (*blob-set-u8! ((or blob string) number fixnum -> undefined))
    31       (*blob-set-u16-le! ((or blob string) number fixnum -> undefined))
    32       (*blob-set-u32-le! ((or blob string) number fixnum -> undefined))
    33       (*blob-set-u64-le! ((or blob string) number fixnum -> undefined))
    34       (*blob-set-u16-be! ((or blob string) number fixnum -> undefined))
    35       (*blob-set-u32-be! ((or blob string) number fixnum -> undefined))
    36       (*blob-set-u64-be! ((or blob string) number fixnum -> undefined))
    37 
    38       (blob-set-u8! (blob fixnum #!optional fixnum -> undefined))
    39       (blob-set-u16-le! (blob fixnum #!optional fixnum -> undefined))
    40       (blob-set-u32-le! (blob number #!optional fixnum -> undefined))
    41       (blob-set-u64-le! (blob number #!optional fixnum -> undefined))
    42       (blob-set-u16-be! (blob fixnum #!optional fixnum -> undefined))
    43       (blob-set-u32-be! (blob number #!optional fixnum -> undefined))
    44       (blob-set-u64-be! (blob number #!optional fixnum -> undefined)) ) )
     10(;export
     11  blob-set-u8!
     12  blob-set-u16-le! blob-set-u32-le! blob-set-u64-le!
     13  blob-set-u16-be! blob-set-u32-be! blob-set-u64-be!
     14  ;
     15  *blob-set-u8!
     16  *blob-set-u16-le! *blob-set-u32-le! *blob-set-u64-le!
     17  *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
     18
     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))
    4541
    4642;;; Only Blob Bytevector, No Argument Checking
     
    122118
    123119(define (blob-set-u8! blb uint #!optional (off 0))
    124         (check-blob 'blob-set-u8! blb)
    125         (check-natural-fixnum 'blob-set-u8! off 'offset)
    126         (check-fixnum 'blob-set-u8! uint)
    127   (*blob-set-u8! blb uint off) )
     120  (*blob-set-u8!
     121    (check-blob 'blob-set-u8! blb)
     122    (check-fixnum 'blob-set-u8! uint)
     123    (check-natural-fixnum 'blob-set-u8! off 'offset)) )
    128124
    129125;; Little Endian 16, 32, & 64
    130126
    131127(define (blob-set-u16-le! blb uint #!optional (off 0))
    132         (check-blob 'blob-set-u16-le! blb)
    133         (check-natural-fixnum 'blob-set-u16-le! off 'offset)
    134         (check-fixnum 'blob-set-u16-le! uint)
    135   (*blob-set-u16-le! blb uint off) )
     128  (*blob-set-u16-le!
     129    (check-blob 'blob-set-u16-le! blb)
     130    (check-fixnum 'blob-set-u16-le! uint)
     131    (check-natural-fixnum 'blob-set-u16-le! off 'offset)) )
    136132
    137133(define (blob-set-u32-le! blb uint #!optional (off 0))
    138         (check-blob 'blob-set-u32-le! blb)
    139         (check-natural-fixnum 'blob-set-u32-le! off 'offset)
    140         (check-integer 'blob-set-u32-le! uint)
    141   (*blob-set-u32-le! blb uint off) )
     134  (*blob-set-u32-le!
     135    (check-blob 'blob-set-u32-le! blb)
     136    (check-integer 'blob-set-u32-le! uint)
     137    (check-natural-fixnum 'blob-set-u32-le! off 'offset)) )
    142138
    143139(define (blob-set-u64-le! blb uint #!optional (off 0))
    144         (check-blob 'blob-set-u64-le! blb)
    145         (check-natural-fixnum 'blob-set-u64-le! off 'offset)
    146         (check-integer 'blob-set-u64-le! uint)
    147   (*blob-set-u64-le! blb uint off) )
     140  (*blob-set-u64-le!
     141    (check-blob 'blob-set-u64-le! blb)
     142    (check-integer 'blob-set-u64-le! uint)
     143    (check-natural-fixnum 'blob-set-u64-le! off 'offset)) )
    148144
    149145;; Big Endian 16, 32, & 64
    150146
    151147(define (blob-set-u16-be! blb uint #!optional (off 0))
    152         (check-blob 'blob-set-u16-be! blb)
    153         (check-natural-fixnum 'blob-set-u16-be! off 'offset)
    154         (check-fixnum 'blob-set-u16-be! uint)
    155   (*blob-set-u16-be! blb uint off) )
     148  (*blob-set-u16-be!
     149    (check-blob 'blob-set-u16-be! blb)
     150    (check-fixnum 'blob-set-u16-be! uint)
     151    (check-natural-fixnum 'blob-set-u16-be! off 'offset)) )
    156152
    157153(define (blob-set-u32-be! blb uint #!optional (off 0))
    158         (check-blob 'blob-set-u32-be! blb)
    159         (check-natural-fixnum 'blob-set-u32-be! off 'offset)
    160         (check-integer 'blob-set-u32-be! uint)
    161   (*blob-set-u32-be! blb uint off) )
     154  (*blob-set-u32-be!
     155    (check-blob 'blob-set-u32-be! blb)
     156    (check-integer 'blob-set-u32-be! uint)
     157    (check-natural-fixnum 'blob-set-u32-be! off 'offset)) )
    162158
    163159(define (blob-set-u64-be! blb uint #!optional (off 0))
    164         (check-blob 'blob-set-u64-be! blb)
    165         (check-natural-fixnum 'blob-set-u64-be! off 'offset)
    166         (check-integer 'blob-set-u64-be! uint)
    167   (*blob-set-u64-be! blb uint off) )
     160  (*blob-set-u64-be!
     161    (check-blob 'blob-set-u64-be! blb)
     162    (check-integer 'blob-set-u64-be! uint)
     163    (check-natural-fixnum 'blob-set-u64-be! off 'offset)) )
    168164
    169165#| ;Useful API?
     
    174170(define (get-bv-alias loc obj)
    175171  (cond
    176     ((blob? obj)                        obj )
    177     ((string? obj)              obj )
    178     ((u8vector? obj)    (u8vector->blob/shared obj) )
     172    ((blob? obj)
     173      obj )
     174    ((string? obj)
     175      obj )
     176    ((u8vector? obj)
     177      (u8vector->blob/shared obj) )
    179178    (else
    180179        (error-argument-type loc obj "blob, u8vector, or string" obj) ) ) )
     
    183182(define (get-byte-order loc obj)
    184183  (case obj
    185         ((big-endian be big msb)                                'big-endian )
    186         ((little-endian le little lsb)  'little-endian )
     184        ((big-endian be big msb)
     185          'big-endian )
     186        ((little-endian le little lsb)
     187          'little-endian )
    187188    (else
    188189        (error-argument-type loc obj "symbol in {big-endian be big msb little-endian le little lsb}" obj) ) ) )
     
    220221        (let ((bv (get-bv-alias 'set-u16! bv)))
    221222                (case (get-byte-order 'set-u16! order)
    222                         ((little-endian)        (blob-set-u16-le! bv uint idx) )
    223                         ((big-endian)                   (blob-set-u16-be! bv uint idx) ) ) ) )
     223                        ((little-endian)
     224                          (blob-set-u16-le! bv uint idx) )
     225                        ((big-endian)
     226                          (blob-set-u16-be! bv uint idx) ) ) ) )
    224227
    225228(define (set-u32! bv uint #!optional (idx 0) (order (machine-byte-order)))
    226229        (let ((bv (get-bv-alias 'set-u32! bv)))
    227230                (case (get-byte-order 'set-u32! order)
    228                         ((little-endian)        (blob-set-u32-le! bv uint idx) )
    229                         ((big-endian)                   (blob-set-u32-be! bv uint idx) ) ) ) )
     231                        ((little-endian)
     232                          (blob-set-u32-le! bv uint idx) )
     233                        ((big-endian)
     234                          (blob-set-u32-be! bv uint idx) ) ) ) )
    230235
    231236(define (set-u64! bv uint #!optional (idx 0) (order (machine-byte-order)))
    232237        (let ((bv (get-bv-alias 'set-u64! bv)))
    233238                (case (get-byte-order 'set-u64! order)
    234                         ((little-endian)        (blob-set-u64-le! bv uint idx) )
    235                         ((big-endian)                   (blob-set-u64-be! bv uint idx) ) ) ) )
     239                        ((little-endian)
     240                          (blob-set-u64-le! bv uint idx) )
     241                        ((big-endian)
     242                          (blob-set-u64-be! bv uint idx) ) ) ) )
    236243|#
    237244
  • release/4/blob-utils/tags/1.0.4/blob-utils.meta

    r27987 r34149  
    99 (depends
    1010        (setup-helper "1.5.2")
     11        ;to-hex
    1112        (string-utils "1.2.2"))
    1213 (test-depends test)
  • release/4/blob-utils/tags/1.0.4/blob-utils.setup

    r27996 r34149  
    55(verify-extension-name "blob-utils")
    66
    7 (setup-shared+static-extension-module 'blob-set-int (extension-version "1.0.3")
     7(setup-shared+static-extension-module 'blob-set-int (extension-version "1.0.4")
    88  #:types? #t
    99  #:inline? #t
    1010  #:compile-options '(
    11     -scrutinize
    12     -optimize-level 3 -debug-level 1
     11    -optimize-level 3 -debug-level 2
    1312    -no-procedure-checks -no-argc-checks -no-bound-checks))
    1413
    15 (setup-shared-extension-module 'blob-hexadecimal (extension-version "1.0.3")
     14(setup-shared-extension-module 'blob-hexadecimal (extension-version "1.0.4")
    1615  #:types? #t
    1716  #:inline? #t
    1817  #:compile-options '(
    19     -scrutinize
    20     -fixnum-arithmetic
    21     -O3 -d1
     18    -optimize-level 3 -debug-level 2
    2219    -no-procedure-checks))
    2320
    24 (install-extension-tag 'blob-utils (extension-version "1.0.3"))
     21#;
     22(setup-shared-extension-module 'pack-integer (extension-version "1.0.4")
     23  #:types? #t
     24  #:inline? #t
     25  #:compile-options '(
     26    -optimize-level 3 -debug-level 2
     27    -no-procedure-checks))
     28
     29(install-extension-tag 'blob-utils (extension-version "1.0.4"))
  • release/4/blob-utils/tags/1.0.4/pack-integer.scm

    r26405 r34149  
    55
    66;; Issues
    7 
    8 (module pack-integer
    9 
    10   (;export
    11                 pack-u8 pack-u16 pack-u32 pack-u64 pack-integer)
    12 
    13   (import
    14     scheme
    15     chicken
    16     foreign
    17     (only type-checks check-blob check-integer)
    18     (only type-errors error-argument-type))
    19 
    20   (require-library
    21     type-checks type-errors)
    22 
    23 ;;; Integer Packing Utilities
    24 
    25 ;;
    267
    278#>
     
    8162<#
    8263
     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)
     81
     82;;; Integer Packing Utilities
     83
     84;;
     85
    8386;;
    8487
     
    122125
    123126(define (byte-order? obj)
    124   (and (memq obj '(big-endian be big little-endian le little))
    125        #t) )
     127  (and
     128    (memq obj '(big-endian be big little-endian le little))
     129    #t) )
    126130
    127131(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
     
    129133#; ;UNUSED
    130134(define (direction->byte-order n)
    131   (if (negative? n) 'big-endian
     135  (if (negative? n)
     136    'big-endian
    132137    'little-endian ) )
    133138
    134139(define-inline (byte-order->direction order)
    135140  (case order
    136     ((big-endian be big)        -1 )
    137     ((little-endian le little)  1 ) ) )
     141    ((big-endian be big)
     142      -1 )
     143    ((little-endian le little)
     144      1 ) ) )
    138145
    139146(define-error-type byte-buffer "u8vector, blob, string or symbol in {u8vector blob string}" )
     
    158165      ((symbol? bufsel)
    159166        (case bufsel
    160           ((string)     (values 'string (make-string need-size)) )
    161           ((blob)       (values 'blob (make-blob need-size)) )
    162           ((u8vector)   (values 'u8vector (make-u8vector need-size)) )
     167          ((string)
     168            (values 'string (make-string need-size)) )
     169          ((blob)
     170            (values 'blob (make-blob need-size)) )
     171          ((u8vector)
     172            (values 'u8vector (make-u8vector need-size)) )
    163173          (else
    164174            (error-byte-buffer loc bufsel) ) ) )
     
    179189(define (*pack-u8 loc n bufsel start)
    180190  (check-integer loc n)
    181   (let-values (((typ obj) (ensure-byte-buffer loc 1 bufsel start)))
     191  (receive (typ obj) (ensure-byte-buffer loc 1 bufsel start)
    182192    (case typ
    183       ((string)   (pack-u8/string! obj n start) )
    184       ((blob)     (pack-u8/blob! obj n start) )
    185       ((u8vector) (pack-u8/u8vector! obj n start) ) )
     193      ((string)
     194        (pack-u8/string! obj n start) )
     195      ((blob)
     196        (pack-u8/blob! obj n start) )
     197      ((u8vector)
     198        (pack-u8/u8vector! obj n start) ) )
    186199    obj ) )
    187200
     
    194207  (check-integer loc n)
    195208  (check-byte-order loc order)
    196   (let-values (((typ obj) (ensure-byte-buffer loc size bufsel start)))
     209  (receive (typ obj) (ensure-byte-buffer loc size bufsel start)
    197210    (let ((direction (byte-order->direction order)))
    198211      (case typ
    199         ((string)   (pack-u64/string! obj n size direction start) )
    200         ((blob)     (pack-u64/blob! obj n size direction start) )
    201         ((u8vector) (pack-u64/u8vector! obj n size direction start) ) ) )
     212        ((string)
     213          (pack-u64/string! obj n size direction start) )
     214        ((blob)
     215          (pack-u64/blob! obj n size direction start) )
     216        ((u8vector)
     217          (pack-u64/u8vector! obj n size direction start) ) ) )
    202218    obj ) )
    203219
     
    221237(define (pack-integer n #!key (bufsel 'string) (start 0) (order (machine-byte-order)) (size 4))
    222238  (check-byte-size 'pack-integer size)
    223   (if (fx= 1 size) (*blob-set-u8! 'pack-integer n bufsel start)
     239  (if (fx= 1 size)
     240    (*blob-set-u8! 'pack-integer n bufsel start)
    224241    (*pack-integer 'pack-integer n bufsel size order start) ) )
    225242
  • release/4/blob-utils/tags/1.0.4/tests/run.scm

    r26405 r34149  
    11(use test)
     2
    23(use blob-hexadecimal)
    3 (use blob-set-int)
    44
    55(test-begin "Blob Utils")
     
    1111)
    1212
     13(use blob-set-int)
     14
    1315#;
    1416(test-group "Set Int"
  • release/4/blob-utils/trunk/blob-hexadecimal.scm

    r27987 r34149  
    44(module blob-hexadecimal
    55
    6   (;export
    7     blob->hex)
     6(;export
     7  blob->hex)
    88
    9   (import
    10     scheme
    11     chicken
    12     (only to-hex blob_to_hex)
    13     (only type-checks check-natural-fixnum check-blob))
     9(import scheme)
    1410
    15   (require-library to-hex type-checks)
     11(import chicken foreign)
    1612
    17   (declare
    18     (bound-to-procedure
    19       ##sys#signal-hook))
     13(import
     14  (only to-hex blob_to_hex)
     15  (only type-checks check-natural-fixnum check-blob))
     16(require-library to-hex type-checks)
    2017
    21   (declare
    22     (type
    23       (blob->hex (blob #!optional fixnum (or fixnum boolean) -> string)) ) )
     18(declare
     19  (bound-to-procedure
     20    ##sys#signal-hook))
    2421
    2522;;
    2623
     24(: blob->hex (blob #!optional fixnum (or fixnum boolean) -> string))
    2725(define (blob->hex blb #!optional (start 0) (end #f))
    2826  (check-blob 'blob->hex blb)
     
    3129  (let ((end (or end (blob-size blb))))
    3230    (unless (<= start end)
    33       (##sys#signal-hook #:bounds-error 'blob->hex
    34                          "illegal subvector specification" start end))
     31      (##sys#signal-hook
     32        #:bounds-error 'blob->hex
     33        "illegal subvector specification" start end))
    3534    (let ((len (fx- end start)))
    36       (if (fx= 0 len) ""
     35      (if (fx= 0 len)
     36        ""
    3737        (let ((res (make-string (fx* len 2))))
    3838          (blob_to_hex res blb start len)
  • release/4/blob-utils/trunk/blob-set-int.scm

    r27996 r34149  
    88(module blob-set-int
    99
    10   (;export
    11     blob-set-u8!
    12     blob-set-u16-le! blob-set-u32-le! blob-set-u64-le!
    13     blob-set-u16-be! blob-set-u32-be! blob-set-u64-be!
    14     ;
    15     *blob-set-u8!
    16     *blob-set-u16-le! *blob-set-u32-le! *blob-set-u64-le!
    17     *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
    18 
    19   (import
    20     scheme
    21     chicken
    22     foreign
    23     (only type-checks check-natural-fixnum check-blob check-fixnum check-integer))
    24 
    25   (require-library
    26     type-checks)
    27 
    28   (declare
    29     (type
    30       (*blob-set-u8! ((or blob string) number fixnum -> undefined))
    31       (*blob-set-u16-le! ((or blob string) number fixnum -> undefined))
    32       (*blob-set-u32-le! ((or blob string) number fixnum -> undefined))
    33       (*blob-set-u64-le! ((or blob string) number fixnum -> undefined))
    34       (*blob-set-u16-be! ((or blob string) number fixnum -> undefined))
    35       (*blob-set-u32-be! ((or blob string) number fixnum -> undefined))
    36       (*blob-set-u64-be! ((or blob string) number fixnum -> undefined))
    37 
    38       (blob-set-u8! (blob fixnum #!optional fixnum -> undefined))
    39       (blob-set-u16-le! (blob fixnum #!optional fixnum -> undefined))
    40       (blob-set-u32-le! (blob number #!optional fixnum -> undefined))
    41       (blob-set-u64-le! (blob number #!optional fixnum -> undefined))
    42       (blob-set-u16-be! (blob fixnum #!optional fixnum -> undefined))
    43       (blob-set-u32-be! (blob number #!optional fixnum -> undefined))
    44       (blob-set-u64-be! (blob number #!optional fixnum -> undefined)) ) )
     10(;export
     11  blob-set-u8!
     12  blob-set-u16-le! blob-set-u32-le! blob-set-u64-le!
     13  blob-set-u16-be! blob-set-u32-be! blob-set-u64-be!
     14  ;
     15  *blob-set-u8!
     16  *blob-set-u16-le! *blob-set-u32-le! *blob-set-u64-le!
     17  *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
     18
     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))
    4541
    4642;;; Only Blob Bytevector, No Argument Checking
     
    122118
    123119(define (blob-set-u8! blb uint #!optional (off 0))
    124         (check-blob 'blob-set-u8! blb)
    125         (check-natural-fixnum 'blob-set-u8! off 'offset)
    126         (check-fixnum 'blob-set-u8! uint)
    127   (*blob-set-u8! blb uint off) )
     120  (*blob-set-u8!
     121    (check-blob 'blob-set-u8! blb)
     122    (check-fixnum 'blob-set-u8! uint)
     123    (check-natural-fixnum 'blob-set-u8! off 'offset)) )
    128124
    129125;; Little Endian 16, 32, & 64
    130126
    131127(define (blob-set-u16-le! blb uint #!optional (off 0))
    132         (check-blob 'blob-set-u16-le! blb)
    133         (check-natural-fixnum 'blob-set-u16-le! off 'offset)
    134         (check-fixnum 'blob-set-u16-le! uint)
    135   (*blob-set-u16-le! blb uint off) )
     128  (*blob-set-u16-le!
     129    (check-blob 'blob-set-u16-le! blb)
     130    (check-fixnum 'blob-set-u16-le! uint)
     131    (check-natural-fixnum 'blob-set-u16-le! off 'offset)) )
    136132
    137133(define (blob-set-u32-le! blb uint #!optional (off 0))
    138         (check-blob 'blob-set-u32-le! blb)
    139         (check-natural-fixnum 'blob-set-u32-le! off 'offset)
    140         (check-integer 'blob-set-u32-le! uint)
    141   (*blob-set-u32-le! blb uint off) )
     134  (*blob-set-u32-le!
     135    (check-blob 'blob-set-u32-le! blb)
     136    (check-integer 'blob-set-u32-le! uint)
     137    (check-natural-fixnum 'blob-set-u32-le! off 'offset)) )
    142138
    143139(define (blob-set-u64-le! blb uint #!optional (off 0))
    144         (check-blob 'blob-set-u64-le! blb)
    145         (check-natural-fixnum 'blob-set-u64-le! off 'offset)
    146         (check-integer 'blob-set-u64-le! uint)
    147   (*blob-set-u64-le! blb uint off) )
     140  (*blob-set-u64-le!
     141    (check-blob 'blob-set-u64-le! blb)
     142    (check-integer 'blob-set-u64-le! uint)
     143    (check-natural-fixnum 'blob-set-u64-le! off 'offset)) )
    148144
    149145;; Big Endian 16, 32, & 64
    150146
    151147(define (blob-set-u16-be! blb uint #!optional (off 0))
    152         (check-blob 'blob-set-u16-be! blb)
    153         (check-natural-fixnum 'blob-set-u16-be! off 'offset)
    154         (check-fixnum 'blob-set-u16-be! uint)
    155   (*blob-set-u16-be! blb uint off) )
     148  (*blob-set-u16-be!
     149    (check-blob 'blob-set-u16-be! blb)
     150    (check-fixnum 'blob-set-u16-be! uint)
     151    (check-natural-fixnum 'blob-set-u16-be! off 'offset)) )
    156152
    157153(define (blob-set-u32-be! blb uint #!optional (off 0))
    158         (check-blob 'blob-set-u32-be! blb)
    159         (check-natural-fixnum 'blob-set-u32-be! off 'offset)
    160         (check-integer 'blob-set-u32-be! uint)
    161   (*blob-set-u32-be! blb uint off) )
     154  (*blob-set-u32-be!
     155    (check-blob 'blob-set-u32-be! blb)
     156    (check-integer 'blob-set-u32-be! uint)
     157    (check-natural-fixnum 'blob-set-u32-be! off 'offset)) )
    162158
    163159(define (blob-set-u64-be! blb uint #!optional (off 0))
    164         (check-blob 'blob-set-u64-be! blb)
    165         (check-natural-fixnum 'blob-set-u64-be! off 'offset)
    166         (check-integer 'blob-set-u64-be! uint)
    167   (*blob-set-u64-be! blb uint off) )
     160  (*blob-set-u64-be!
     161    (check-blob 'blob-set-u64-be! blb)
     162    (check-integer 'blob-set-u64-be! uint)
     163    (check-natural-fixnum 'blob-set-u64-be! off 'offset)) )
    168164
    169165#| ;Useful API?
     
    174170(define (get-bv-alias loc obj)
    175171  (cond
    176     ((blob? obj)                        obj )
    177     ((string? obj)              obj )
    178     ((u8vector? obj)    (u8vector->blob/shared obj) )
     172    ((blob? obj)
     173      obj )
     174    ((string? obj)
     175      obj )
     176    ((u8vector? obj)
     177      (u8vector->blob/shared obj) )
    179178    (else
    180179        (error-argument-type loc obj "blob, u8vector, or string" obj) ) ) )
     
    183182(define (get-byte-order loc obj)
    184183  (case obj
    185         ((big-endian be big msb)                                'big-endian )
    186         ((little-endian le little lsb)  'little-endian )
     184        ((big-endian be big msb)
     185          'big-endian )
     186        ((little-endian le little lsb)
     187          'little-endian )
    187188    (else
    188189        (error-argument-type loc obj "symbol in {big-endian be big msb little-endian le little lsb}" obj) ) ) )
     
    220221        (let ((bv (get-bv-alias 'set-u16! bv)))
    221222                (case (get-byte-order 'set-u16! order)
    222                         ((little-endian)        (blob-set-u16-le! bv uint idx) )
    223                         ((big-endian)                   (blob-set-u16-be! bv uint idx) ) ) ) )
     223                        ((little-endian)
     224                          (blob-set-u16-le! bv uint idx) )
     225                        ((big-endian)
     226                          (blob-set-u16-be! bv uint idx) ) ) ) )
    224227
    225228(define (set-u32! bv uint #!optional (idx 0) (order (machine-byte-order)))
    226229        (let ((bv (get-bv-alias 'set-u32! bv)))
    227230                (case (get-byte-order 'set-u32! order)
    228                         ((little-endian)        (blob-set-u32-le! bv uint idx) )
    229                         ((big-endian)                   (blob-set-u32-be! bv uint idx) ) ) ) )
     231                        ((little-endian)
     232                          (blob-set-u32-le! bv uint idx) )
     233                        ((big-endian)
     234                          (blob-set-u32-be! bv uint idx) ) ) ) )
    230235
    231236(define (set-u64! bv uint #!optional (idx 0) (order (machine-byte-order)))
    232237        (let ((bv (get-bv-alias 'set-u64! bv)))
    233238                (case (get-byte-order 'set-u64! order)
    234                         ((little-endian)        (blob-set-u64-le! bv uint idx) )
    235                         ((big-endian)                   (blob-set-u64-be! bv uint idx) ) ) ) )
     239                        ((little-endian)
     240                          (blob-set-u64-le! bv uint idx) )
     241                        ((big-endian)
     242                          (blob-set-u64-be! bv uint idx) ) ) ) )
    236243|#
    237244
  • release/4/blob-utils/trunk/blob-utils.meta

    r27987 r34149  
    99 (depends
    1010        (setup-helper "1.5.2")
     11        ;to-hex
    1112        (string-utils "1.2.2"))
    1213 (test-depends test)
  • release/4/blob-utils/trunk/blob-utils.setup

    r27996 r34149  
    55(verify-extension-name "blob-utils")
    66
    7 (setup-shared+static-extension-module 'blob-set-int (extension-version "1.0.3")
     7(setup-shared+static-extension-module 'blob-set-int (extension-version "1.0.4")
    88  #:types? #t
    99  #:inline? #t
    1010  #:compile-options '(
    11     -scrutinize
    12     -optimize-level 3 -debug-level 1
     11    -optimize-level 3 -debug-level 2
    1312    -no-procedure-checks -no-argc-checks -no-bound-checks))
    1413
    15 (setup-shared-extension-module 'blob-hexadecimal (extension-version "1.0.3")
     14(setup-shared-extension-module 'blob-hexadecimal (extension-version "1.0.4")
    1615  #:types? #t
    1716  #:inline? #t
    1817  #:compile-options '(
    19     -scrutinize
    20     -fixnum-arithmetic
    21     -O3 -d1
     18    -optimize-level 3 -debug-level 2
    2219    -no-procedure-checks))
    2320
    24 (install-extension-tag 'blob-utils (extension-version "1.0.3"))
     21#;
     22(setup-shared-extension-module 'pack-integer (extension-version "1.0.4")
     23  #:types? #t
     24  #:inline? #t
     25  #:compile-options '(
     26    -optimize-level 3 -debug-level 2
     27    -no-procedure-checks))
     28
     29(install-extension-tag 'blob-utils (extension-version "1.0.4"))
  • release/4/blob-utils/trunk/pack-integer.scm

    r26405 r34149  
    55
    66;; Issues
    7 
    8 (module pack-integer
    9 
    10   (;export
    11                 pack-u8 pack-u16 pack-u32 pack-u64 pack-integer)
    12 
    13   (import
    14     scheme
    15     chicken
    16     foreign
    17     (only type-checks check-blob check-integer)
    18     (only type-errors error-argument-type))
    19 
    20   (require-library
    21     type-checks type-errors)
    22 
    23 ;;; Integer Packing Utilities
    24 
    25 ;;
    267
    278#>
     
    8162<#
    8263
     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)
     81
     82;;; Integer Packing Utilities
     83
     84;;
     85
    8386;;
    8487
     
    122125
    123126(define (byte-order? obj)
    124   (and (memq obj '(big-endian be big little-endian le little))
    125        #t) )
     127  (and
     128    (memq obj '(big-endian be big little-endian le little))
     129    #t) )
    126130
    127131(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
     
    129133#; ;UNUSED
    130134(define (direction->byte-order n)
    131   (if (negative? n) 'big-endian
     135  (if (negative? n)
     136    'big-endian
    132137    'little-endian ) )
    133138
    134139(define-inline (byte-order->direction order)
    135140  (case order
    136     ((big-endian be big)        -1 )
    137     ((little-endian le little)  1 ) ) )
     141    ((big-endian be big)
     142      -1 )
     143    ((little-endian le little)
     144      1 ) ) )
    138145
    139146(define-error-type byte-buffer "u8vector, blob, string or symbol in {u8vector blob string}" )
     
    158165      ((symbol? bufsel)
    159166        (case bufsel
    160           ((string)     (values 'string (make-string need-size)) )
    161           ((blob)       (values 'blob (make-blob need-size)) )
    162           ((u8vector)   (values 'u8vector (make-u8vector need-size)) )
     167          ((string)
     168            (values 'string (make-string need-size)) )
     169          ((blob)
     170            (values 'blob (make-blob need-size)) )
     171          ((u8vector)
     172            (values 'u8vector (make-u8vector need-size)) )
    163173          (else
    164174            (error-byte-buffer loc bufsel) ) ) )
     
    179189(define (*pack-u8 loc n bufsel start)
    180190  (check-integer loc n)
    181   (let-values (((typ obj) (ensure-byte-buffer loc 1 bufsel start)))
     191  (receive (typ obj) (ensure-byte-buffer loc 1 bufsel start)
    182192    (case typ
    183       ((string)   (pack-u8/string! obj n start) )
    184       ((blob)     (pack-u8/blob! obj n start) )
    185       ((u8vector) (pack-u8/u8vector! obj n start) ) )
     193      ((string)
     194        (pack-u8/string! obj n start) )
     195      ((blob)
     196        (pack-u8/blob! obj n start) )
     197      ((u8vector)
     198        (pack-u8/u8vector! obj n start) ) )
    186199    obj ) )
    187200
     
    194207  (check-integer loc n)
    195208  (check-byte-order loc order)
    196   (let-values (((typ obj) (ensure-byte-buffer loc size bufsel start)))
     209  (receive (typ obj) (ensure-byte-buffer loc size bufsel start)
    197210    (let ((direction (byte-order->direction order)))
    198211      (case typ
    199         ((string)   (pack-u64/string! obj n size direction start) )
    200         ((blob)     (pack-u64/blob! obj n size direction start) )
    201         ((u8vector) (pack-u64/u8vector! obj n size direction start) ) ) )
     212        ((string)
     213          (pack-u64/string! obj n size direction start) )
     214        ((blob)
     215          (pack-u64/blob! obj n size direction start) )
     216        ((u8vector)
     217          (pack-u64/u8vector! obj n size direction start) ) ) )
    202218    obj ) )
    203219
     
    221237(define (pack-integer n #!key (bufsel 'string) (start 0) (order (machine-byte-order)) (size 4))
    222238  (check-byte-size 'pack-integer size)
    223   (if (fx= 1 size) (*blob-set-u8! 'pack-integer n bufsel start)
     239  (if (fx= 1 size)
     240    (*blob-set-u8! 'pack-integer n bufsel start)
    224241    (*pack-integer 'pack-integer n bufsel size order start) ) )
    225242
  • release/4/blob-utils/trunk/tests/run.scm

    r26405 r34149  
    11(use test)
     2
    23(use blob-hexadecimal)
    3 (use blob-set-int)
    44
    55(test-begin "Blob Utils")
     
    1111)
    1212
     13(use blob-set-int)
     14
    1315#;
    1416(test-group "Set Int"
Note: See TracChangeset for help on using the changeset viewer.