;;; -*-lisp-*-
;;;
;;; Test handling of C types
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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 expand-tabs (string)
  (with-output-to-string (out)
    (do ((i 0 (1+ i))
	 (char (char string 0) (char string i))
	 (pos 0))
	((>= i (length string)))
      (case char
	(#\newline (write-char char out)
		   (setf pos 0))
	(#\tab (write-string "        " out :end (- 8 (mod pos 8)))
	       (setf pos (logandc2 (+ pos 8) 7)))
	(t (write-char char out)
	   (incf pos))))))

(defun assert-pp-ctype (type kernel string)
  (let* ((*print-right-margin* 77)
	 (*print-pretty* t)
	 (print (with-output-to-string (out)
		  (pprint-c-type type out kernel))))
    (assert-equal (expand-tabs print) (expand-tabs 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*/)")))

;;;--------------------------------------------------------------------------
;;; Parsing.

(defun check-c-type-parse (string c-type name)
  (let* ((char-scanner (make-string-scanner string))
	 (scanner (make-instance 'sod-token-scanner
				 :char-scanner char-scanner
				 :filename "<none>")))
    (with-parser-context (token-scanner-context :scanner scanner)
      (define-module ("<temporary>" :truename nil :location scanner)
	(multiple-value-bind (result winp consumedp)
	    (parse (seq ((ds (parse-c-type scanner))
			 (dc (parse-declarator scanner ds))
			 :eof)
		     dc))
	  (declare (ignore consumedp))
	  (cond ((null c-type)
		 (assert-false winp))
		(t
		 (assert-true winp)
		 (unless (eq c-type t)
		   (assert-cteqp (car result) c-type))
		 (unless (eq name t)
		   (assert-equal (cdr result) name)))))))))

(def-test-method parse-simple ((test c-types-test) :run nil)
  (check-c-type-parse "int x" (c-type int) "x"))

(def-test-method parse-hairy-declspec ((test c-types-test) :run nil)
  (check-c-type-parse "int long unsigned long y"
		      (c-type unsigned-long-long) "y"))

(def-test-method parse-bogus-declspec ((test c-types-test) :run nil)
  (check-c-type-parse "int long int x" nil nil))

(def-test-method parse-array ((test c-types-test) :run nil)
  (check-c-type-parse "float v[69][42]" (c-type ([] float "69" "42")) "v"))

(def-test-method parse-array-of-pointers ((test c-types-test) :run nil)
  (check-c-type-parse "const char *const tab[]"
		      (c-type ([] (* (char :const) :const) ""))
		      "tab"))

(def-test-method parse-hairy-function-pointer ((test c-types-test) :run nil)
  (check-c-type-parse "void (*signal(int, void (*)(int)))(int)"
		      (c-type (func (* (func void (nil int)))
				    (nil int)
				    (nil (* (func void (nil int))))))
		      "signal"))

;;;----- That's all, folks --------------------------------------------------