--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Test handling of C types
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-test)
+
+;;;--------------------------------------------------------------------------
+;;; Here we go.
+
+(defclass c-types-test (test-case) ())
+(add-test *sod-test-suite* (get-suite c-types-test))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun assert-cteqp (a b)
+ (unless (c-type-equal-p a b)
+ (failure "Assert equal C types: ~A ~_and ~A" a b)))
+
+(defun assert-not-cteqp (a b)
+ (when (c-type-equal-p a b)
+ (failure "Assert unequal C types: ~A ~_and ~A" a b)))
+
+(defun assert-pp-ctype (type kernel string)
+ (let* ((*print-right-margin* 77)
+ (print (with-output-to-string (out)
+ (pprint-c-type type out kernel))))
+ (assert-equal print string
+ (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~
+ rather than `~A'."
+ type kernel print string))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple types.
+
+(def-test-method intern-trivial-simple-type ((test c-types-test) :run nil)
+ (assert-eql (c-type "foo") (make-simple-type "foo")))
+
+(def-test-method intern-qualified-simple-type ((test c-types-test) :run nil)
+ (assert-eql (c-type ("foo" :const :volatile))
+ (make-simple-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-simple-type ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo")))
+
+(def-test-method print-simple-type ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type "foo") "f" "foo f"))
+
+(def-test-method print-simple-type-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type "foo") nil "foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Tagged types.
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+ (assert-eql (c-type (struct "foo")) (make-struct-type "foo")))
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+ (assert-eql (c-type (enum "foo" :const :volatile))
+ (make-enum-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-tagged-type ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (enum "foo" :restrict))
+ (make-union-type "foo" '(:restrict))))
+
+(def-test-method print-struct-type ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f"))
+
+(def-test-method print-union-type-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (union "foo")) nil "union foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+(def-test-method intern-trivial-pointer ((test c-types-test) :run nil)
+ (assert-eql (c-type (* "foo"))
+ (make-pointer-type (make-simple-type "foo"))))
+
+(def-test-method intern-qualified-pointer ((test c-types-test) :run nil)
+ (assert-eql (c-type (* "foo" :const :volatile))
+ (make-pointer-type (make-simple-type "foo")
+ '(:volatile :const))))
+
+(def-test-method intern-double-indirection ((test c-types-test) :run nil)
+ (assert-eql (c-type (* (* "foo")))
+ (make-pointer-type
+ (make-pointer-type (make-simple-type "foo")))))
+
+(def-test-method non-intern-complex-pointer ((test c-types-test) :run nil)
+ ;; The protocol doesn't specify what we do here; but we want to avoid
+ ;; interning pointers to non-interned types in order to prevent the intern
+ ;; table filling up with cruft. So test anyway.
+ (let ((a (c-type (* ([] "foo" 16))))
+ (b (make-pointer-type
+ (make-array-type (make-simple-type "foo") '(16)))))
+ (assert-not-eql a b)
+ (assert-cteqp a b)))
+
+(def-test-method print-pointer ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char)) "p" "char *p"))
+
+(def-test-method print-qualified-pointer ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p"))
+
+(def-test-method print-pointer-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char)) nil "char *"))
+
+(def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char :const)) nil "char *const"))
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+(def-test-method compare-simple-arrays ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] int 10))
+ (make-array-type (make-simple-type "int") (list 10))))
+
+(def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] int 10 4))
+ (c-type ([] ([] int 4) 10))))
+
+(def-test-method compare-multiarrays ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method bad-compare-multiarrays ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 5) 10))))
+
+(def-test-method compare-misshaped ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method print-array ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo"
+ "int foo[10][9][8][7][6]"))
+
+(def-test-method print-array-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil
+ "int[10][9][8][7][6]"))
+
+(def-test-method print-array-of-pointers ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] (* char))) nil "char *[]"))
+
+(def-test-method print-pointer-to-array ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]"))
+
+;;;--------------------------------------------------------------------------
+;;; Function types.
+
+(def-test-method compare-simple-functions ((test c-types-test) :run nil)
+ ;; Argument names don't matter.
+ (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+ (make-function-type (make-simple-type "int")
+ (list
+ (make-argument "foo"
+ (make-simple-type "int"))
+ (make-argument "bar"
+ (c-type double))))))
+
+(def-test-method build-argument-tail ((test c-types-test) :run nil)
+ (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+ (c-type (fun int ("foo" int)
+ . (list (make-argument "bar"
+ (c-type double)))))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+ (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+ (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method print-signal ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (fun (* (fun int (nil int)))
+ ("signo" int)
+ ("handler" (* (fun int (nil int))))))
+ "signal"
+ "int (*signal(int signo, int (*handler)(int)))(int)"))
+
+(def-test-method print-commentify ((test c-types-test) :run nil)
+ (assert-pp-ctype (commentify-function-type
+ (c-type (fun int
+ ("n" size-t)
+ (nil string)
+ ("format" const-string)
+ :ellipsis)))
+ "snprintf"
+ (concatenate 'string
+ "int snprintf(size_t /*n*/, char *, "
+ "const char */*format*/, "
+ "...)")))
+
+(def-test-method commentify-non-recursive ((test c-types-test) :run nil)
+ ;; Also checks pretty-printing.
+ (assert-pp-ctype (commentify-function-type
+ (c-type (fun int
+ ("dirpath" const-string)
+ ("fn" (* (fun int
+ ("fpath" const-string)
+ ("sb" (* (struct "stat"
+ :const)))
+ ("typeflag" int))))
+ ("nopenfd" int))))
+ "ftw"
+ (format nil "~
+int ftw(const char */*dirpath*/,
+ int (*/*fn*/)(const char *fpath,
+ const struct stat *sb,
+ int typeflag),
+ int /*nopenfd*/)")))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff