Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Test handling of C types | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
11 | ;;; |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod-test) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Here we go. | |
30 | ||
31 | (defclass c-types-test (test-case) ()) | |
32 | (add-test *sod-test-suite* (get-suite c-types-test)) | |
33 | ||
34 | ;;;-------------------------------------------------------------------------- | |
35 | ;;; Utilities. | |
36 | ||
37 | (defun assert-cteqp (a b) | |
38 | (unless (c-type-equal-p a b) | |
39 | (failure "Assert equal C types: ~A ~_and ~A" a b))) | |
40 | ||
41 | (defun assert-not-cteqp (a b) | |
42 | (when (c-type-equal-p a b) | |
43 | (failure "Assert unequal C types: ~A ~_and ~A" a b))) | |
44 | ||
239fa5bd MW |
45 | (defun expand-tabs (string) |
46 | (with-output-to-string (out) | |
47 | (do ((i 0 (1+ i)) | |
48 | (char (char string 0) (char string i)) | |
49 | (pos 0)) | |
50 | ((>= i (length string))) | |
51 | (case char | |
52 | (#\newline (write-char char out) | |
53 | (setf pos 0)) | |
54 | (#\tab (write-string " " out :end (- 8 (mod pos 8))) | |
55 | (setf pos (logandc2 (+ pos 8) 7))) | |
56 | (t (write-char char out) | |
57 | (incf pos)))))) | |
58 | ||
dea4d055 MW |
59 | (defun assert-pp-ctype (type kernel string) |
60 | (let* ((*print-right-margin* 77) | |
d0b51392 | 61 | (*print-pretty* t) |
dea4d055 MW |
62 | (print (with-output-to-string (out) |
63 | (pprint-c-type type out kernel)))) | |
239fa5bd | 64 | (assert-equal (expand-tabs print) (expand-tabs string) |
dea4d055 MW |
65 | (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~ |
66 | rather than `~A'." | |
67 | type kernel print string)))) | |
68 | ||
69 | ;;;-------------------------------------------------------------------------- | |
70 | ;;; Simple types. | |
71 | ||
72 | (def-test-method intern-trivial-simple-type ((test c-types-test) :run nil) | |
73 | (assert-eql (c-type "foo") (make-simple-type "foo"))) | |
74 | ||
75 | (def-test-method intern-qualified-simple-type ((test c-types-test) :run nil) | |
76 | (assert-eql (c-type ("foo" :const :volatile)) | |
77 | (make-simple-type "foo" '(:volatile :const :volatile)))) | |
78 | ||
79 | (def-test-method mismatch-simple-type ((test c-types-test) :run nil) | |
80 | (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo"))) | |
81 | ||
82 | (def-test-method print-simple-type ((test c-types-test) :run nil) | |
83 | (assert-pp-ctype (c-type "foo") "f" "foo f")) | |
84 | ||
85 | (def-test-method print-simple-type-abs ((test c-types-test) :run nil) | |
86 | (assert-pp-ctype (c-type "foo") nil "foo")) | |
87 | ||
88 | ;;;-------------------------------------------------------------------------- | |
89 | ;;; Tagged types. | |
90 | ||
91 | (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) | |
92 | (assert-eql (c-type (struct "foo")) (make-struct-type "foo"))) | |
93 | ||
94 | (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) | |
95 | (assert-eql (c-type (enum "foo" :const :volatile)) | |
96 | (make-enum-type "foo" '(:volatile :const :volatile)))) | |
97 | ||
98 | (def-test-method mismatch-tagged-type ((test c-types-test) :run nil) | |
99 | (assert-not-cteqp (c-type (enum "foo" :restrict)) | |
100 | (make-union-type "foo" '(:restrict)))) | |
101 | ||
102 | (def-test-method print-struct-type ((test c-types-test) :run nil) | |
103 | (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f")) | |
104 | ||
105 | (def-test-method print-union-type-abs ((test c-types-test) :run nil) | |
106 | (assert-pp-ctype (c-type (union "foo")) nil "union foo")) | |
107 | ||
108 | ;;;-------------------------------------------------------------------------- | |
109 | ;;; Pointer types. | |
110 | ||
111 | (def-test-method intern-trivial-pointer ((test c-types-test) :run nil) | |
112 | (assert-eql (c-type (* "foo")) | |
113 | (make-pointer-type (make-simple-type "foo")))) | |
114 | ||
115 | (def-test-method intern-qualified-pointer ((test c-types-test) :run nil) | |
116 | (assert-eql (c-type (* "foo" :const :volatile)) | |
117 | (make-pointer-type (make-simple-type "foo") | |
118 | '(:volatile :const)))) | |
119 | ||
120 | (def-test-method intern-double-indirection ((test c-types-test) :run nil) | |
121 | (assert-eql (c-type (* (* "foo"))) | |
122 | (make-pointer-type | |
123 | (make-pointer-type (make-simple-type "foo"))))) | |
124 | ||
125 | (def-test-method non-intern-complex-pointer ((test c-types-test) :run nil) | |
126 | ;; The protocol doesn't specify what we do here; but we want to avoid | |
127 | ;; interning pointers to non-interned types in order to prevent the intern | |
128 | ;; table filling up with cruft. So test anyway. | |
129 | (let ((a (c-type (* ([] "foo" 16)))) | |
130 | (b (make-pointer-type | |
131 | (make-array-type (make-simple-type "foo") '(16))))) | |
132 | (assert-not-eql a b) | |
133 | (assert-cteqp a b))) | |
134 | ||
135 | (def-test-method print-pointer ((test c-types-test) :run nil) | |
136 | (assert-pp-ctype (c-type (* char)) "p" "char *p")) | |
137 | ||
138 | (def-test-method print-qualified-pointer ((test c-types-test) :run nil) | |
139 | (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p")) | |
140 | ||
141 | (def-test-method print-pointer-abs ((test c-types-test) :run nil) | |
142 | (assert-pp-ctype (c-type (* char)) nil "char *")) | |
143 | ||
144 | (def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil) | |
145 | (assert-pp-ctype (c-type (* char :const)) nil "char *const")) | |
146 | ||
147 | ;;;-------------------------------------------------------------------------- | |
148 | ;;; Array types. | |
149 | ||
150 | (def-test-method compare-simple-arrays ((test c-types-test) :run nil) | |
151 | (assert-cteqp (c-type ([] int 10)) | |
152 | (make-array-type (make-simple-type "int") (list 10)))) | |
153 | ||
154 | (def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil) | |
155 | (assert-cteqp (c-type ([] int 10 4)) | |
156 | (c-type ([] ([] int 4) 10)))) | |
157 | ||
158 | (def-test-method compare-multiarrays ((test c-types-test) :run nil) | |
159 | (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8)) | |
160 | (c-type ([] ([] ([] int 6) 9 8 7) 10)))) | |
161 | ||
162 | (def-test-method bad-compare-multiarrays ((test c-types-test) :run nil) | |
163 | (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8)) | |
164 | (c-type ([] ([] ([] int 6) 9 8 5) 10)))) | |
165 | ||
166 | (def-test-method compare-misshaped ((test c-types-test) :run nil) | |
167 | (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8)) | |
168 | (c-type ([] ([] ([] int 6) 9 8 7) 10)))) | |
169 | ||
170 | (def-test-method print-array ((test c-types-test) :run nil) | |
171 | (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo" | |
172 | "int foo[10][9][8][7][6]")) | |
173 | ||
174 | (def-test-method print-array-abs ((test c-types-test) :run nil) | |
175 | (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil | |
176 | "int[10][9][8][7][6]")) | |
177 | ||
178 | (def-test-method print-array-of-pointers ((test c-types-test) :run nil) | |
179 | (assert-pp-ctype (c-type ([] (* char))) nil "char *[]")) | |
180 | ||
181 | (def-test-method print-pointer-to-array ((test c-types-test) :run nil) | |
182 | (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]")) | |
183 | ||
184 | ;;;-------------------------------------------------------------------------- | |
185 | ;;; Function types. | |
186 | ||
187 | (def-test-method compare-simple-functions ((test c-types-test) :run nil) | |
188 | ;; Argument names don't matter. | |
189 | (assert-cteqp (c-type (fun int ("a" int) ("b" double))) | |
190 | (make-function-type (make-simple-type "int") | |
191 | (list | |
192 | (make-argument "foo" | |
193 | (make-simple-type "int")) | |
194 | (make-argument "bar" | |
195 | (c-type double)))))) | |
196 | ||
197 | (def-test-method build-argument-tail ((test c-types-test) :run nil) | |
198 | (assert-cteqp (c-type (fun int ("a" int) ("b" double))) | |
199 | (c-type (fun int ("foo" int) | |
200 | . (list (make-argument "bar" | |
201 | (c-type double))))))) | |
202 | ||
203 | (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) | |
204 | (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) | |
205 | (c-type (fun int ("y" int) ("z" double))))) | |
206 | ||
207 | (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) | |
208 | (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) | |
209 | (c-type (fun int ("y" int) ("z" double))))) | |
210 | ||
211 | (def-test-method print-signal ((test c-types-test) :run nil) | |
212 | (assert-pp-ctype (c-type (fun (* (fun int (nil int))) | |
213 | ("signo" int) | |
214 | ("handler" (* (fun int (nil int)))))) | |
215 | "signal" | |
216 | "int (*signal(int signo, int (*handler)(int)))(int)")) | |
217 | ||
218 | (def-test-method print-commentify ((test c-types-test) :run nil) | |
219 | (assert-pp-ctype (commentify-function-type | |
220 | (c-type (fun int | |
221 | ("n" size-t) | |
222 | (nil string) | |
223 | ("format" const-string) | |
224 | :ellipsis))) | |
225 | "snprintf" | |
226 | (concatenate 'string | |
227 | "int snprintf(size_t /*n*/, char *, " | |
228 | "const char */*format*/, " | |
229 | "...)"))) | |
230 | ||
231 | (def-test-method commentify-non-recursive ((test c-types-test) :run nil) | |
232 | ;; Also checks pretty-printing. | |
233 | (assert-pp-ctype (commentify-function-type | |
234 | (c-type (fun int | |
235 | ("dirpath" const-string) | |
236 | ("fn" (* (fun int | |
237 | ("fpath" const-string) | |
238 | ("sb" (* (struct "stat" | |
239 | :const))) | |
240 | ("typeflag" int)))) | |
241 | ("nopenfd" int)))) | |
242 | "ftw" | |
243 | (format nil "~ | |
243cffbf MW |
244 | int ftw |
245 | (const char */*dirpath*/, | |
246 | int (*/*fn*/) | |
247 | (const char *fpath, const struct stat *sb, int typeflag), | |
3109662a | 248 | int /*nopenfd*/)"))) |
dea4d055 | 249 | |
239fa5bd MW |
250 | ;;;-------------------------------------------------------------------------- |
251 | ;;; Parsing. | |
252 | ||
048d0b2d MW |
253 | (defun check-c-type-parse (string c-type name) |
254 | (let* ((char-scanner (make-string-scanner string)) | |
255 | (scanner (make-instance 'sod-token-scanner | |
256 | :char-scanner char-scanner | |
257 | :filename "<none>"))) | |
258 | (with-parser-context (token-scanner-context :scanner scanner) | |
259 | (define-module ("<temporary>" :truename nil :location scanner) | |
260 | (multiple-value-bind (result winp consumedp) | |
261 | (parse (seq ((ds (parse-c-type scanner)) | |
262 | (dc (parse-declarator scanner ds)) | |
263 | :eof) | |
264 | dc)) | |
265 | (declare (ignore consumedp)) | |
266 | (cond ((null c-type) | |
267 | (assert-false winp)) | |
268 | (t | |
269 | (assert-true winp) | |
270 | (unless (eq c-type t) | |
271 | (assert-cteqp (car result) c-type)) | |
272 | (unless (eq name t) | |
273 | (assert-equal (cdr result) name))))))))) | |
274 | ||
275 | (def-test-method parse-simple ((test c-types-test) :run nil) | |
276 | (check-c-type-parse "int x" (c-type int) "x")) | |
277 | ||
278 | (def-test-method parse-hairy-declspec ((test c-types-test) :run nil) | |
279 | (check-c-type-parse "int long unsigned long y" | |
280 | (c-type unsigned-long-long) "y")) | |
281 | ||
282 | (def-test-method parse-bogus-declspec ((test c-types-test) :run nil) | |
283 | (check-c-type-parse "int long int x" nil nil)) | |
284 | ||
285 | (def-test-method parse-array ((test c-types-test) :run nil) | |
286 | (check-c-type-parse "float v[69][42]" (c-type ([] float "69" "42")) "v")) | |
287 | ||
288 | (def-test-method parse-array-of-pointers ((test c-types-test) :run nil) | |
289 | (check-c-type-parse "const char *const tab[]" | |
290 | (c-type ([] (* (char :const) :const) "")) | |
291 | "tab")) | |
292 | ||
293 | (def-test-method parse-hairy-function-pointer ((test c-types-test) :run nil) | |
294 | (check-c-type-parse "void (*signal(int, void (*)(int)))(int)" | |
295 | (c-type (func (* (func void (nil int))) | |
296 | (nil int) | |
297 | (nil (* (func void (nil int)))))) | |
ea578bb4 | 298 | "signal")) |
239fa5bd | 299 | |
dea4d055 | 300 | ;;;----- That's all, folks -------------------------------------------------- |