chiark - git - mdw - sod/blob - src/c-types-test.lisp

   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 Sensible 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
  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
  59 (defun assert-pp-ctype (type kernel string)
  60   (let* ((*print-right-margin* 77)
  61          (*print-pretty* t)
  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' ~_~
  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 "~
 244 int ftw
 245        (const char */*dirpath*/,
 246         int (*/*fn*/)
 247                (const char *fpath, const struct stat *sb, int typeflag),
 248         int /*nopenfd*/)")))
 249
 250 ;;;--------------------------------------------------------------------------
 251 ;;; Parsing.
 252
 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))))))
 298                       "signal"))
 299
 300 ;;;----- That's all, folks --------------------------------------------------