1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
;;; Warning: nasal demons.
;;;
;;; Will output differences between GCC's behavior and our behavior, but not in
;;; a very nice format. Zero output is good. The C code and Scheme procedure
;;; we generate are fairly straightforward so read the code to understand.
(define-module (bytestructures bitfield-tests))
(export run-bitfield-tests)
(use-modules (srfi srfi-1)
(srfi srfi-9)
(ice-9 rdelim)
(bytestructures r6 bytevectors)
(bytestructures guile))
(define-record-type <struct>
(make-struct name fields)
struct?
(name struct-name)
(fields struct-fields))
(define-record-type <field>
(make-field name int-size bit-size signed? value)
struct?
(name field-name)
(int-size field-int-size)
(bit-size field-bit-size)
(signed? field-signed?)
(value field-value))
(define *keep-files* (make-parameter #f))
(define (run-bitfield-tests count random-seed-string keep-files)
(set! *random-state* (seed->random-state random-seed-string))
(parameterize ((*keep-files* keep-files))
(test-structs (generate-structs count))))
(define (generate-structs n)
(remove-bad-structs (map random-struct (iota n))))
(define (remove-bad-structs structs)
(filter (lambda (struct)
(find (lambda (field)
(not (zero? (field-bit-size field))))
(struct-fields struct)))
structs))
(define (random-struct i)
(let ((field-count (+ 1 (random 50))))
(make-struct (format #f "s~a" i)
(map random-field (iota field-count)))))
(define (random-field i)
(let* ((name (format #f "f~a" i))
(int-size (* 8 (expt 2 (random 4))))
(bit-size (random (+ 1 int-size)))
(signed? (= 0 (random 2)))
(value (random (expt 2 bit-size)))
(value (if (and signed? (> value (+ -1 (expt 2 (- bit-size 1)))))
(- value (expt 2 bit-size))
value)))
(make-field name int-size bit-size signed? value)))
(define (test-structs structs)
(let* ((c-code (c-code-for-structs structs))
(c-output (get-c-output c-code))
(scm-code (scm-code-for-structs structs))
(scm-output (get-scm-output scm-code)))
(diff-outputs c-output scm-output)))
(define (c-code-for-structs structs)
(string-concatenate
(append
(list "#include <stdio.h>\n"
"#include <stdint.h>\n"
"#include <strings.h>\n"
"int main(){\n")
(map c-code-for-struct structs)
(list "return 0;}"))))
(define (c-code-for-struct struct)
(let ((name (struct-name struct))
(fields (struct-fields struct)))
(string-concatenate
(append
(list (format #f "struct ~a {\n" name))
(map c-decl-for-field fields)
(list "};\n"
(format #f "{ struct ~a foo;\n" name)
(format #f " bzero((void*)&foo, sizeof(foo));\n"))
(map c-assignment-for-field fields)
(list (format #f " printf(\"struct ~a:\\n\");\n" name)
" uint8_t *ptr = (void*)&foo;\n"
" for (int i = 0; i < sizeof(foo); ++i) {\n"
" printf(\"%d \", *(ptr+i));\n"
" }\n"
" printf(\"\\n\");\n"
"}\n")))))
(define (c-decl-for-field field)
(let ((name (field-name field))
(int-size (field-int-size field))
(bit-size (field-bit-size field))
(signed? (field-signed? field)))
(format #f " ~aint~a_t ~a:~a;\n"
(if signed? "" "u")
int-size
(if (zero? bit-size) "" name)
bit-size)))
(define (c-assignment-for-field field)
(let ((name (field-name field))
(bit-size (field-bit-size field))
(signed? (field-signed? field))
(value (field-value field)))
(if (zero? bit-size)
""
(format #f " foo.~a = ~a~a;\n" name value (if signed? "" "u")))))
(define (get-c-output code)
(let* ((port (mkstemp! (string-copy "/tmp/bitfield-XXXXXX")))
(file (port-filename port))
(exe-port (mkstemp! (string-copy "/tmp/bitfield-compiled-XXXXXX")))
(exe-file (port-filename exe-port))
(output-port (mkstemp! (string-copy "/tmp/bitfield-output-XXXXXX")))
(output-file (port-filename output-port)))
(close-port exe-port)
(close-port output-port)
(display code port)
(force-output port)
(unless (zero? (system* "gcc" "-x" "c" "-std=c11" file "-o" exe-file))
(error "gcc failed"))
(unless (zero? (system (format #f "~a > ~a" exe-file output-file)))
(error "exe failed"))
(let ((out (read-string (open output-file O_RDONLY))))
(unless (*keep-files*)
(for-each delete-file (list file exe-file output-file)))
out)))
(define (scm-code-for-structs structs)
(lambda ()
(string-concatenate
(map scm-code-for-struct structs))))
(define (scm-code-for-struct struct)
(let* ((name (struct-name struct))
(fields (struct-fields struct))
(descriptor (struct->descriptor struct))
(values (map field-value (filter-nonzero-fields fields)))
(bs (bytestructure descriptor (list->vector values))))
(string-concatenate
(append
(list (format #f "struct ~a:\n" name))
(let ((bv (bytestructure-bytevector bs)))
(map (lambda (i)
(format #f "~a " (bytevector-u8-ref bv i)))
(iota (bytevector-length bv))))
(list "\n")))))
(define (struct->descriptor struct)
(let ((fields (struct-fields struct)))
(bs:struct (map field->struct-descriptor-field fields))))
(define (field->struct-descriptor-field field)
(let ((name (field-name field))
(int-size (field-int-size field))
(bit-size (field-bit-size field))
(signed? (field-signed? field)))
(list name
(module-ref (resolve-module
'(bytestructures bitfield-tests))
(string->symbol
(format #f "~aint~a"
(if signed? "" "u")
int-size)))
bit-size)))
(define (filter-nonzero-fields fields)
(filter (lambda (field)
(not (zero? (field-bit-size field))))
fields))
(define (get-scm-output code)
(code))
(define (diff-outputs o1 o2)
(let* ((p1 (mkstemp! (string-copy "/tmp/bitfield-out1-XXXXXX")))
(f1 (port-filename p1))
(p2 (mkstemp! (string-copy "/tmp/bitfield-out2-XXXXXX")))
(f2 (port-filename p2)))
(display o1 p1)
(display o2 p2)
(flush-all-ports)
(close-port p1)
(close-port p2)
(let ((retval (system* "diff" "-y" "--suppress-common" f1 f2)))
(unless (*keep-files*)
(for-each delete-file (list f1 f2)))
retval)))
|
