3 ;;; Test handling of C types
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble 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 assert-pp-ctype (type kernel string)
46 (let* ((*print-right-margin* 77)
47 (print (with-output-to-string (out)
48 (pprint-c-type type out kernel))))
49 (assert-equal print string
50 (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~
52 type kernel print string))))
54 ;;;--------------------------------------------------------------------------
57 (def-test-method intern-trivial-simple-type ((test c-types-test) :run nil)
58 (assert-eql (c-type "foo") (make-simple-type "foo")))
60 (def-test-method intern-qualified-simple-type ((test c-types-test) :run nil)
61 (assert-eql (c-type ("foo" :const :volatile))
62 (make-simple-type "foo" '(:volatile :const :volatile))))
64 (def-test-method mismatch-simple-type ((test c-types-test) :run nil)
65 (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo")))
67 (def-test-method print-simple-type ((test c-types-test) :run nil)
68 (assert-pp-ctype (c-type "foo") "f" "foo f"))
70 (def-test-method print-simple-type-abs ((test c-types-test) :run nil)
71 (assert-pp-ctype (c-type "foo") nil "foo"))
73 ;;;--------------------------------------------------------------------------
76 (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
77 (assert-eql (c-type (struct "foo")) (make-struct-type "foo")))
79 (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
80 (assert-eql (c-type (enum "foo" :const :volatile))
81 (make-enum-type "foo" '(:volatile :const :volatile))))
83 (def-test-method mismatch-tagged-type ((test c-types-test) :run nil)
84 (assert-not-cteqp (c-type (enum "foo" :restrict))
85 (make-union-type "foo" '(:restrict))))
87 (def-test-method print-struct-type ((test c-types-test) :run nil)
88 (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f"))
90 (def-test-method print-union-type-abs ((test c-types-test) :run nil)
91 (assert-pp-ctype (c-type (union "foo")) nil "union foo"))
93 ;;;--------------------------------------------------------------------------
96 (def-test-method intern-trivial-pointer ((test c-types-test) :run nil)
97 (assert-eql (c-type (* "foo"))
98 (make-pointer-type (make-simple-type "foo"))))
100 (def-test-method intern-qualified-pointer ((test c-types-test) :run nil)
101 (assert-eql (c-type (* "foo" :const :volatile))
102 (make-pointer-type (make-simple-type "foo")
103 '(:volatile :const))))
105 (def-test-method intern-double-indirection ((test c-types-test) :run nil)
106 (assert-eql (c-type (* (* "foo")))
108 (make-pointer-type (make-simple-type "foo")))))
110 (def-test-method non-intern-complex-pointer ((test c-types-test) :run nil)
111 ;; The protocol doesn't specify what we do here; but we want to avoid
112 ;; interning pointers to non-interned types in order to prevent the intern
113 ;; table filling up with cruft. So test anyway.
114 (let ((a (c-type (* ([] "foo" 16))))
115 (b (make-pointer-type
116 (make-array-type (make-simple-type "foo") '(16)))))
120 (def-test-method print-pointer ((test c-types-test) :run nil)
121 (assert-pp-ctype (c-type (* char)) "p" "char *p"))
123 (def-test-method print-qualified-pointer ((test c-types-test) :run nil)
124 (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p"))
126 (def-test-method print-pointer-abs ((test c-types-test) :run nil)
127 (assert-pp-ctype (c-type (* char)) nil "char *"))
129 (def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil)
130 (assert-pp-ctype (c-type (* char :const)) nil "char *const"))
132 ;;;--------------------------------------------------------------------------
135 (def-test-method compare-simple-arrays ((test c-types-test) :run nil)
136 (assert-cteqp (c-type ([] int 10))
137 (make-array-type (make-simple-type "int") (list 10))))
139 (def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil)
140 (assert-cteqp (c-type ([] int 10 4))
141 (c-type ([] ([] int 4) 10))))
143 (def-test-method compare-multiarrays ((test c-types-test) :run nil)
144 (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8))
145 (c-type ([] ([] ([] int 6) 9 8 7) 10))))
147 (def-test-method bad-compare-multiarrays ((test c-types-test) :run nil)
148 (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8))
149 (c-type ([] ([] ([] int 6) 9 8 5) 10))))
151 (def-test-method compare-misshaped ((test c-types-test) :run nil)
152 (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8))
153 (c-type ([] ([] ([] int 6) 9 8 7) 10))))
155 (def-test-method print-array ((test c-types-test) :run nil)
156 (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo"
157 "int foo[10][9][8][7][6]"))
159 (def-test-method print-array-abs ((test c-types-test) :run nil)
160 (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil
161 "int[10][9][8][7][6]"))
163 (def-test-method print-array-of-pointers ((test c-types-test) :run nil)
164 (assert-pp-ctype (c-type ([] (* char))) nil "char *[]"))
166 (def-test-method print-pointer-to-array ((test c-types-test) :run nil)
167 (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]"))
169 ;;;--------------------------------------------------------------------------
172 (def-test-method compare-simple-functions ((test c-types-test) :run nil)
173 ;; Argument names don't matter.
174 (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
175 (make-function-type (make-simple-type "int")
178 (make-simple-type "int"))
182 (def-test-method build-argument-tail ((test c-types-test) :run nil)
183 (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
184 (c-type (fun int ("foo" int)
185 . (list (make-argument "bar"
186 (c-type double)))))))
188 (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
189 (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
190 (c-type (fun int ("y" int) ("z" double)))))
192 (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
193 (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
194 (c-type (fun int ("y" int) ("z" double)))))
196 (def-test-method print-signal ((test c-types-test) :run nil)
197 (assert-pp-ctype (c-type (fun (* (fun int (nil int)))
199 ("handler" (* (fun int (nil int))))))
201 "int (*signal(int signo, int (*handler)(int)))(int)"))
203 (def-test-method print-commentify ((test c-types-test) :run nil)
204 (assert-pp-ctype (commentify-function-type
208 ("format" const-string)
212 "int snprintf(size_t /*n*/, char *, "
213 "const char */*format*/, "
216 (def-test-method commentify-non-recursive ((test c-types-test) :run nil)
217 ;; Also checks pretty-printing.
218 (assert-pp-ctype (commentify-function-type
220 ("dirpath" const-string)
222 ("fpath" const-string)
223 ("sb" (* (struct "stat"
229 int ftw(const char */*dirpath*/,
230 int (*/*fn*/)(const char *fpath,
231 const struct stat *sb,
235 ;;;----- That's all, folks --------------------------------------------------