source: project/release/5/string-utils/trunk/string-hexadecimal.scm @ 35791

Last change on this file since 35791 was 35791, checked in by kon, 4 months ago

C5 initial

File size: 5.0 KB
Line 
1;;;; string-hexadecimal.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Aug '17
4;;;; Kon Lovett, Aug '10
5
6#>
7static void
8bv_to_hex( uint8_t *out, uint8_t *in, int off, int len )
9{
10  static char digits[] = "0123456789abcdef";
11
12  in += off;
13  while( len-- ) {
14    *out++ = digits[ *in >> 4 ];
15    *out++ = digits[ *in++ & 0x0f ];
16  }
17}
18
19static void
20hex_to_bv( uint8_t *out, uint8_t *in, int off, int len )
21{
22# define hex_nibble(c)  (isdigit(c) ? ((c) - '0') : (((c) - 'a') + 10))
23
24  in += off;
25  while( 0 <= (len -= 2) ) {
26    unsigned char in0 = tolower( in[0] );
27    unsigned char in1 = tolower( in[1] );
28    *out++ = (hex_nibble( in0 ) << 4) | hex_nibble( in1 );
29    in += 2;
30  }
31
32# undef hex_nibble
33}
34<#
35
36(declare
37  (bound-to-procedure
38    ##sys#signal-hook
39    ##sys#make-string))
40
41(module string-hexadecimal
42
43(;export
44  ;
45  mem_to_hex
46  s8vec_to_hex
47  u8vec_to_hex
48  blob_to_hex
49  str_to_hex
50  ;
51  hex_to_str
52  hex_to_blob
53  ;
54  string->hex *string->hex
55  hex->string *hex->string)
56
57(import scheme
58  (chicken base)
59  (chicken fixnum)
60  (chicken type)
61  (chicken foreign)
62  (chicken memory representation)
63  (only type-checks check-natural-fixnum check-string))
64
65;;;
66
67(define-inline (fxzero? x)
68  (fx= 0 x) )
69
70;;;
71
72(define (check-subvector-indexes loc start end)
73  (unless
74    (fx<=
75      (check-natural-fixnum loc start 'start)
76      (check-natural-fixnum loc end 'end))
77    (##sys#signal-hook #:bounds-error loc "illegal subvector specification" start end) ) )
78
79;;
80
81(define C_str_to_hex
82  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-scheme-pointer int int))
83
84(define C_blob_to_hex
85  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-blob int int))
86
87(define C_u8vec_to_hex
88  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-u8vector int int))
89
90(define C_s8vec_to_hex
91  (foreign-lambda*
92      void ((nonnull-scheme-pointer out) (nonnull-s8vector in) (int off) (int len))
93    "bv_to_hex( out, ((uint8_t *) in), off, len );"))
94
95(define C_mem_to_hex
96  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-c-pointer int int))
97
98;;
99
100(define C_hex_to_str
101  (foreign-lambda void "hex_to_bv" nonnull-scheme-pointer nonnull-scheme-pointer int int))
102
103;;
104
105(: str_to_hex (string string fixnum fixnum -> string))
106;
107(define (str_to_hex out in off len)
108  (C_str_to_hex out in off len)
109  out )
110
111(: blob_to_hex (string blob fixnum fixnum -> string))
112;
113(define (blob_to_hex out in off len)
114  (C_blob_to_hex out in off len)
115  out )
116
117(: u8vec_to_hex (string u8vector fixnum fixnum -> string))
118;
119(define (u8vec_to_hex out in off len)
120  (C_u8vec_to_hex out in off len)
121  out )
122
123(: s8vec_to_hex (string s8vector fixnum fixnum -> string))
124;
125(define (s8vec_to_hex out in off len)
126  (C_s8vec_to_hex out in off len)
127  out )
128
129(: mem_to_hex (string pointer fixnum fixnum -> string))
130;
131(define (mem_to_hex out in off len)
132  (C_mem_to_hex out in off len)
133  out )
134
135;;
136
137(: hex_to_str (string string fixnum fixnum -> string))
138;
139(define (hex_to_str out in off len)
140  (C_hex_to_str out in off len)
141  out )
142
143(: hex_to_blob (blob string fixnum fixnum -> blob))
144;
145(define (hex_to_blob out in off len)
146  (C_hex_to_str out in off len)
147  out )
148
149
150;;
151
152(: string->hex (string #!optional fixnum (or boolean fixnum) --> string))
153;
154(define (string->hex str #!optional (start 0) (end #f))
155  (check-string 'string->hex str)
156  (let ((end (or end (number-of-bytes str))))
157    (check-subvector-indexes 'string->hex start end)
158    (*string->hex str start end) ) )
159
160(: hex->string (string #!optional fixnum --> string))
161;
162(define (hex->string str #!optional (start 0) (end #f))
163  (let ((len (number-of-bytes (check-string 'hex->string str))))
164    (unless (fxzero? (fxmod len 2))
165      (error 'hex->string "too few characters" str) )
166    (let ((end (or end len)))
167      (check-subvector-indexes 'hex->string start end)
168      (*hex->string str start end) ) ) )
169
170;;
171
172(: *string->hex (string fixnum fixnum --> string))
173;
174(define (*string->hex str start end)
175  (let ((len (fx- end start)))
176    (if (fxzero? len)
177      ""
178      (str_to_hex (##sys#make-string (fx* len 2)) str start len) ) ) )
179
180(: *hex->string (string fixnum fixnum --> string))
181;
182(define (*hex->string str start end)
183  (let ((len (fx- end start)))
184    (if (fxzero? len)
185      ""
186      (hex_to_str (##sys#make-string (fx/ len 2)) str start len) ) ) )
187
188#|
189(use
190  (only (srfi 1) drop drop-right)
191  (only (srfi 13) string-pad string-concatenate  reverse-list->string))
192
193(define (*string->hex str start end)
194  (let* ((ls (string->list str) )
195         (ls (drop ls start) )
196         (strlen (string-length str) )
197         (ls (drop-right ls (fx- strlen end)) ) )
198    (string-concatenate
199      (map
200        (lambda (c)
201          (string-pad (number->string (char->integer c) 16) 2 #\0))
202      ls)) ) )
203
204(define (*hex->string str)
205  (let ((len (string-length str)))
206    (let loop ((i 0) (ls '()))
207      (if (fx<= len i)
208        (reverse-list->string ls)
209        (let ((ni (fx+ i 2) ))
210          (loop ni (cons (integer->char (string->number (substring str i ni) 16)) ls)) ) ) ) ) )
211|#
212
213) ;module string-hexadecimal
Note: See TracBrowser for help on using the repository browser.