~mdw / sod / blame
| 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 | ;;; | |
| 10 | ;;; This file is part of the Sensble Object Design, an object system for C. | |
| 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) | |
| 61 | (print (with-output-to-string (out) | |
| 62 | (pprint-c-type type out kernel)))) | |
| 239fa5bd | 63 | (assert-equal (expand-tabs print) (expand-tabs string) |
| dea4d055 MW |
64 | (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~ |
| 65 | rather than `~A'." | |
| 66 | type kernel print string)))) | |
| 67 | ||
| 68 | ;;;-------------------------------------------------------------------------- | |
| 69 | ;;; Simple types. | |
| 70 | ||
| 71 | (def-test-method intern-trivial-simple-type ((test c-types-test) :run nil) | |
| 72 | (assert-eql (c-type "foo") (make-simple-type "foo"))) | |
| 73 | ||
| 74 | (def-test-method intern-qualified-simple-type ((test c-types-test) :run nil) | |
| 75 | (assert-eql (c-type ("foo" :const :volatile)) | |
| 76 | (make-simple-type "foo" '(:volatile :const :volatile)))) | |
| 77 | ||
| 78 | (def-test-method mismatch-simple-type ((test c-types-test) :run nil) | |
| 79 | (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo"))) | |
| 80 | ||
| 81 | (def-test-method print-simple-type ((test c-types-test) :run nil) | |
| 82 | (assert-pp-ctype (c-type "foo") "f" "foo f")) | |
| 83 | ||
| 84 | (def-test-method print-simple-type-abs ((test c-types-test) :run nil) | |
| 85 | (assert-pp-ctype (c-type "foo") nil "foo")) | |
| 86 | ||
| 87 | ;;;-------------------------------------------------------------------------- | |
| 88 | ;;; Tagged types. | |
| 89 | ||
| 90 | (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) | |
| 91 | (assert-eql (c-type (struct "foo")) (make-struct-type "foo"))) | |
| 92 | ||
| 93 | (def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) | |
| 94 | (assert-eql (c-type (enum "foo" :const :volatile)) | |
| 95 | (make-enum-type "foo" '(:volatile :const :volatile)))) | |
| 96 | ||
| 97 | (def-test-method mismatch-tagged-type ((test c-types-test) :run nil) | |
| 98 | (assert-not-cteqp (c-type (enum "foo" :restrict)) | |
| 99 | (make-union-type "foo" '(:restrict)))) | |
| 100 | ||
| 101 | (def-test-method print-struct-type ((test c-types-test) :run nil) | |
| 102 | (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f")) | |
| 103 | ||
| 104 | (def-test-method print-union-type-abs ((test c-types-test) :run nil) | |
| 105 | (assert-pp-ctype (c-type (union "foo")) nil "union foo")) | |
| 106 | ||
| 107 | ;;;-------------------------------------------------------------------------- | |
| 108 | ;;; Pointer types. | |
| 109 | ||
| 110 | (def-test-method intern-trivial-pointer ((test c-types-test) :run nil) | |
| 111 | (assert-eql (c-type (* "foo")) | |
| 112 | (make-pointer-type (make-simple-type "foo")))) | |
| 113 | ||
| 114 | (def-test-method intern-qualified-pointer ((test c-types-test) :run nil) | |
| 115 | (assert-eql (c-type (* "foo" :const :volatile)) | |
| 116 | (make-pointer-type (make-simple-type "foo") | |
| 117 | '(:volatile :const)))) | |
| 118 | ||
| 119 | (def-test-method intern-double-indirection ((test c-types-test) :run nil) | |
| 120 | (assert-eql (c-type (* (* "foo"))) | |
| 121 | (make-pointer-type | |
| 122 | (make-pointer-type (make-simple-type "foo"))))) | |
| 123 | ||
| 124 | (def-test-method non-intern-complex-pointer ((test c-types-test) :run nil) | |
| 125 | ;; The protocol doesn't specify what we do here; but we want to avoid | |
| 126 | ;; interning pointers to non-interned types in order to prevent the intern | |
| 127 | ;; table filling up with cruft. So test anyway. | |
| 128 | (let ((a (c-type (* ([] "foo" 16)))) | |
| 129 | (b (make-pointer-type | |
| 130 | (make-array-type (make-simple-type "foo") '(16))))) | |
| 131 | (assert-not-eql a b) | |
| 132 | (assert-cteqp a b))) | |
| 133 | ||
| 134 | (def-test-method print-pointer ((test c-types-test) :run nil) | |
| 135 | (assert-pp-ctype (c-type (* char)) "p" "char *p")) | |
| 136 | ||
| 137 | (def-test-method print-qualified-pointer ((test c-types-test) :run nil) | |
| 138 | (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p")) | |
| 139 | ||
| 140 | (def-test-method print-pointer-abs ((test c-types-test) :run nil) | |
| 141 | (assert-pp-ctype (c-type (* char)) nil "char *")) | |
| 142 | ||
| 143 | (def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil) | |
| 144 | (assert-pp-ctype (c-type (* char :const)) nil "char *const")) | |
| 145 | ||
| 146 | ;;;-------------------------------------------------------------------------- | |
| 147 | ;;; Array types. | |
| 148 | ||
| 149 | (def-test-method compare-simple-arrays ((test c-types-test) :run nil) | |
| 150 | (assert-cteqp (c-type ([] int 10)) | |
| 151 | (make-array-type (make-simple-type "int") (list 10)))) | |
| 152 | ||
| 153 | (def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil) | |
| 154 | (assert-cteqp (c-type ([] int 10 4)) | |
| 155 | (c-type ([] ([] int 4) 10)))) | |
| 156 | ||
| 157 | (def-test-method compare-multiarrays ((test c-types-test) :run nil) | |
| 158 | (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8)) | |
| 159 | (c-type ([] ([] ([] int 6) 9 8 7) 10)))) | |
| 160 | ||
| 161 | (def-test-method bad-compare-multiarrays ((test c-types-test) :run nil) | |
| 162 | (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8)) | |
| 163 | (c-type ([] ([] ([] int 6) 9 8 5) 10)))) | |
| 164 | ||
| 165 | (def-test-method compare-misshaped ((test c-types-test) :run nil) | |
| 166 | (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8)) | |
| 167 | (c-type ([] ([] ([] int 6) 9 8 7) 10)))) | |
| 168 | ||
| 169 | (def-test-method print-array ((test c-types-test) :run nil) | |
| 170 | (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo" | |
| 171 | "int foo[10][9][8][7][6]")) | |
| 172 | ||
| 173 | (def-test-method print-array-abs ((test c-types-test) :run nil) | |
| 174 | (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil | |
| 175 | "int[10][9][8][7][6]")) | |
| 176 | ||
| 177 | (def-test-method print-array-of-pointers ((test c-types-test) :run nil) | |
| 178 | (assert-pp-ctype (c-type ([] (* char))) nil "char *[]")) | |
| 179 | ||
| 180 | (def-test-method print-pointer-to-array ((test c-types-test) :run nil) | |
| 181 | (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]")) | |
| 182 | ||
| 183 | ;;;-------------------------------------------------------------------------- | |
| 184 | ;;; Function types. | |
| 185 | ||
| 186 | (def-test-method compare-simple-functions ((test c-types-test) :run nil) | |
| 187 | ;; Argument names don't matter. | |
| 188 | (assert-cteqp (c-type (fun int ("a" int) ("b" double))) | |
| 189 | (make-function-type (make-simple-type "int") | |
| 190 | (list | |
| 191 | (make-argument "foo" | |
| 192 | (make-simple-type "int")) | |
| 193 | (make-argument "bar" | |
| 194 | (c-type double)))))) | |
| 195 | ||
| 196 | (def-test-method build-argument-tail ((test c-types-test) :run nil) | |
| 197 | (assert-cteqp (c-type (fun int ("a" int) ("b" double))) | |
| 198 | (c-type (fun int ("foo" int) | |
| 199 | . (list (make-argument "bar" | |
| 200 | (c-type double))))))) | |
| 201 | ||
| 202 | (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) | |
| 203 | (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) | |
| 204 | (c-type (fun int ("y" int) ("z" double))))) | |
| 205 | ||
| 206 | (def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) | |
| 207 | (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) | |
| 208 | (c-type (fun int ("y" int) ("z" double))))) | |
| 209 | ||
| 210 | (def-test-method print-signal ((test c-types-test) :run nil) | |
| 211 | (assert-pp-ctype (c-type (fun (* (fun int (nil int))) | |
| 212 | ("signo" int) | |
| 213 | ("handler" (* (fun int (nil int)))))) | |
| 214 | "signal" | |
| 215 | "int (*signal(int signo, int (*handler)(int)))(int)")) | |
| 216 | ||
| 217 | (def-test-method print-commentify ((test c-types-test) :run nil) | |
| 218 | (assert-pp-ctype (commentify-function-type | |
| 219 | (c-type (fun int | |
| 220 | ("n" size-t) | |
| 221 | (nil string) | |
| 222 | ("format" const-string) | |
| 223 | :ellipsis))) | |
| 224 | "snprintf" | |
| 225 | (concatenate 'string | |
| 226 | "int snprintf(size_t /*n*/, char *, " | |
| 227 | "const char */*format*/, " | |
| 228 | "...)"))) | |
| 229 | ||
| 230 | (def-test-method commentify-non-recursive ((test c-types-test) :run nil) | |
| 231 | ;; Also checks pretty-printing. | |
| 232 | (assert-pp-ctype (commentify-function-type | |
| 233 | (c-type (fun int | |
| 234 | ("dirpath" const-string) | |
| 235 | ("fn" (* (fun int | |
| 236 | ("fpath" const-string) | |
| 237 | ("sb" (* (struct "stat" | |
| 238 | :const))) | |
| 239 | ("typeflag" int)))) | |
| 240 | ("nopenfd" int)))) | |
| 241 | "ftw" | |
| 242 | (format nil "~ | |
| 243 | int ftw(const char */*dirpath*/, | |
| 3109662a MW |
244 | int (*/*fn*/)(const char *fpath, |
| 245 | const struct stat *sb, | |
| 246 | int typeflag), | |
| 247 | int /*nopenfd*/)"))) | |
| dea4d055 | 248 | |
| 239fa5bd MW |
249 | ;;;-------------------------------------------------------------------------- |
| 250 | ;;; Parsing. | |
| 251 | ||
| 048d0b2d MW |
252 | (defun check-c-type-parse (string c-type name) |
| 253 | (let* ((char-scanner (make-string-scanner string)) | |
| 254 | (scanner (make-instance 'sod-token-scanner | |
| 255 | :char-scanner char-scanner | |
| 256 | :filename "<none>"))) | |
| 257 | (with-parser-context (token-scanner-context :scanner scanner) | |
| 258 | (define-module ("<temporary>" :truename nil :location scanner) | |
| 259 | (multiple-value-bind (result winp consumedp) | |
| 260 | (parse (seq ((ds (parse-c-type scanner)) | |
| 261 | (dc (parse-declarator scanner ds)) | |
| 262 | :eof) | |
| 263 | dc)) | |
| 264 | (declare (ignore consumedp)) | |
| 265 | (cond ((null c-type) | |
| 266 | (assert-false winp)) | |
| 267 | (t | |
| 268 | (assert-true winp) | |
| 269 | (unless (eq c-type t) | |
| 270 | (assert-cteqp (car result) c-type)) | |
| 271 | (unless (eq name t) | |
| 272 | (assert-equal (cdr result) name))))))))) | |
| 273 | ||
| 274 | (def-test-method parse-simple ((test c-types-test) :run nil) | |
| 275 | (check-c-type-parse "int x" (c-type int) "x")) | |
| 276 | ||
| 277 | (def-test-method parse-hairy-declspec ((test c-types-test) :run nil) | |
| 278 | (check-c-type-parse "int long unsigned long y" | |
| 279 | (c-type unsigned-long-long) "y")) | |
| 280 | ||
| 281 | (def-test-method parse-bogus-declspec ((test c-types-test) :run nil) | |
| 282 | (check-c-type-parse "int long int x" nil nil)) | |
| 283 | ||
| 284 | (def-test-method parse-array ((test c-types-test) :run nil) | |
| 285 | (check-c-type-parse "float v[69][42]" (c-type ([] float "69" "42")) "v")) | |
| 286 | ||
| 287 | (def-test-method parse-array-of-pointers ((test c-types-test) :run nil) | |
| 288 | (check-c-type-parse "const char *const tab[]" | |
| 289 | (c-type ([] (* (char :const) :const) "")) | |
| 290 | "tab")) | |
| 291 | ||
| 292 | (def-test-method parse-hairy-function-pointer ((test c-types-test) :run nil) | |
| 293 | (check-c-type-parse "void (*signal(int, void (*)(int)))(int)" | |
| 294 | (c-type (func (* (func void (nil int))) | |
| 295 | (nil int) | |
| 296 | (nil (* (func void (nil int)))))) | |
| ea578bb4 | 297 | "signal")) |
| 239fa5bd | 298 | |
| dea4d055 | 299 | ;;;----- That's all, folks -------------------------------------------------- |