3 ;;; Test handling of C types
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
26 (cl:in-package #:sod-test)
28 ;;;--------------------------------------------------------------------------
31 (defclass c-types-test (test-case) ())
32 (add-test *sod-test-suite* (get-suite c-types-test))
34 ;;;--------------------------------------------------------------------------
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)))
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)))
45 (defun expand-tabs (string)
46 (with-output-to-string (out)
48 (char (char string 0) (char string i))
50 ((>= i (length string)))
52 (#\newline (write-char char out)
54 (#\tab (write-string " " out :end (- 8 (mod pos 8)))
55 (setf pos (logandc2 (+ pos 8) 7)))
56 (t (write-char char out)
59 (defun assert-pp-ctype (type kernel string)
60 (let* ((*print-right-margin* 77)
62 (print (with-output-to-string (out)
63 (pprint-c-type type out kernel))))
64 (assert-equal (expand-tabs print) (expand-tabs string)
65 (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~
67 type kernel print string))))
69 ;;;--------------------------------------------------------------------------
72 (def-test-method intern-trivial-simple-type ((test c-types-test) :run nil)
73 (assert-eql (c-type "foo") (make-simple-type "foo")))
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))))
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")))
82 (def-test-method print-simple-type ((test c-types-test) :run nil)
83 (assert-pp-ctype (c-type "foo") "f" "foo f"))
85 (def-test-method print-simple-type-abs ((test c-types-test) :run nil)
86 (assert-pp-ctype (c-type "foo") nil "foo"))
88 ;;;--------------------------------------------------------------------------
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")))
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))))
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))))
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"))
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"))
108 ;;;--------------------------------------------------------------------------
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"))))
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))))
120 (def-test-method intern-double-indirection ((test c-types-test) :run nil)
121 (assert-eql (c-type (* (* "foo")))
123 (make-pointer-type (make-simple-type "foo")))))
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)))))
135 (def-test-method print-pointer ((test c-types-test) :run nil)
136 (assert-pp-ctype (c-type (* char)) "p" "char *p"))
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"))
141 (def-test-method print-pointer-abs ((test c-types-test) :run nil)
142 (assert-pp-ctype (c-type (* char)) nil "char *"))
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"))
147 ;;;--------------------------------------------------------------------------
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))))
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))))
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))))
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))))
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))))
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]"))
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]"))
178 (def-test-method print-array-of-pointers ((test c-types-test) :run nil)
179 (assert-pp-ctype (c-type ([] (* char))) nil "char *[]"))
181 (def-test-method print-pointer-to-array ((test c-types-test) :run nil)
182 (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]"))
184 ;;;--------------------------------------------------------------------------
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")
193 (make-simple-type "int"))
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)))))))
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)))))
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)))))
211 (def-test-method print-signal ((test c-types-test) :run nil)
212 (assert-pp-ctype (c-type (fun (* (fun int (nil int)))
214 ("handler" (* (fun int (nil int))))))
216 "int (*signal(int signo, int (*handler)(int)))(int)"))
218 (def-test-method print-commentify ((test c-types-test) :run nil)
219 (assert-pp-ctype (commentify-function-type
223 ("format" const-string)
227 "int snprintf(size_t /*n*/, char *, "
228 "const char */*format*/, "
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
235 ("dirpath" const-string)
237 ("fpath" const-string)
238 ("sb" (* (struct "stat"
245 (const char */*dirpath*/,
247 (const char *fpath, const struct stat *sb, int typeflag),
250 ;;;--------------------------------------------------------------------------
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))
265 (declare (ignore consumedp))
270 (unless (eq c-type t)
271 (assert-cteqp (car result) c-type))
273 (assert-equal (cdr result) name)))))))))
275 (def-test-method parse-simple ((test c-types-test) :run nil)
276 (check-c-type-parse "int x" (c-type int) "x"))
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"))
282 (def-test-method parse-bogus-declspec ((test c-types-test) :run nil)
283 (check-c-type-parse "int long int x" nil nil))
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"))
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) ""))
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)))
297 (nil (* (func void (nil int))))))
300 ;;;----- That's all, folks --------------------------------------------------