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 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
  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 (with-output-to-string (out)
  62                   (pprint-c-type type out kernel))))
  63     (assert-equal (expand-tabs print) (expand-tabs string)
  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*/,
 244         int (*/*fn*/)(const char *fpath,
 245                       const struct stat *sb,
 246                       int typeflag),
 247         int /*nopenfd*/)")))
 248
 249 ;;;--------------------------------------------------------------------------
 250 ;;; Parsing.
 251
 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))))))
 297                       "signal"))
 298
 299 ;;;----- That's all, folks --------------------------------------------------