;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; struct.lisp --- Foreign structure type tests.
;;;

;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>

;;; Copyright (C) 2005-2011, Luis Oliveira  <loliveira@common-lisp.net>

;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

(in-package #:cffi-tests)

(defcstruct timeval
  (tv-secs :long)
  (tv-usecs :long))

(defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
                                       (foreign-type-alignment :long))))

;;;# Basic Structure Tests

(deftest struct.1
    (- (foreign-type-size 'timeval) *timeval-size*)
  0)

(deftest struct.2

    (with-foreign-object (tv 'timeval)

      (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
      (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
      (values (foreign-slot-value tv 'timeval 'tv-secs)
              (foreign-slot-value tv 'timeval 'tv-usecs)))
  0 1)

(deftest struct.3

    (with-foreign-object (tv 'timeval)

      (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
        (setf tv-secs 100 tv-usecs 200)
        (values tv-secs tv-usecs)))
  100 200)

;; regression test: accessing a struct through a typedef

(defctype xpto (:struct timeval))

(deftest struct.4
    (with-foreign-object (tv 'xpto)
      (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
      (values (foreign-slot-value tv 'xpto 'tv-usecs)
              (foreign-slot-value tv 'timeval 'tv-usecs)))
  1 1)

(deftest struct.names

    (sort (foreign-slot-names 'xpto) #'<
          :key (lambda (x) (foreign-slot-offset 'xpto x)))

  (tv-secs tv-usecs))

;; regression test: compiler macro not quoting the type in the
;; resulting mem-ref form. The compiler macro on foreign-slot-value
;; is not guaranteed to be expanded though.

(defctype my-int :int)
(defcstruct s5 (a my-int))

(deftest struct.5
    (with-foreign-object (s 's5)
      (setf (foreign-slot-value s 's5 'a) 42)
      (foreign-slot-value s 's5 'a))
  42)

;;;# Structs with type translators

(defcstruct struct-string
  (s :string))

(deftest struct.string.1

    (with-foreign-object (ptr 'struct-string)

      (with-foreign-slots ((s) ptr struct-string)
        (setf s "So long and thanks for all the fish!")
        s))
  "So long and thanks for all the fish!")

(deftest struct.string.2

    (with-foreign-object (ptr 'struct-string)

      (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
      (foreign-slot-value ptr 'struct-string 's))
  "Cha")

;;;# Structure Alignment Tests

;;;
;;; See libtest.c and types.lisp for some comments about alignments.

(defcstruct s-ch
  (a-char :char))

(defctype s-ch (:struct s-ch))

(defcstruct s-s-ch
  (another-char :char)
  (a-s-ch s-ch))

(defctype s-s-ch (:struct s-s-ch))

(defcvar "the_s_s_ch" s-s-ch)

(deftest struct.alignment.1
    (list 'a-char (foreign-slot-value

                   (foreign-slot-pointer *the-s-s-ch* 's-s-ch 'a-s-ch)

                   's-ch 'a-char)
          'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
  (a-char 1 another-char 2))


(defcstruct s-short
  (a-char :char)
  (another-char :char)
  (a-short :short))

(defctype s-short (:struct s-short))

(defcstruct s-s-short
  (yet-another-char :char)
  (a-s-short s-short))

(defctype s-s-short (:struct s-s-short))

(defcvar "the_s_s_short" s-s-short)

(deftest struct.alignment.2
    (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
      (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
        (list 'a-char           a-char
              'another-char     another-char
              'a-short          a-short
              'yet-another-char yet-another-char)))
  (a-char 1 another-char 2 a-short 3 yet-another-char 4))


(defcstruct s-double
  (a-char :char)
  (a-double :double)
  (another-char :char))

(defctype s-double (:struct s-double))

(defcstruct s-s-double
  (yet-another-char :char)
  (a-s-double s-double)
  (a-short :short))

(defctype s-s-double (:struct s-s-double))

(defcvar "the_s_s_double" s-s-double)

(deftest struct.alignment.3
    (with-foreign-slots
        ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
      (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
        (list 'a-char            a-char
              'a-double          a-double
              'another-char      another-char
              'yet-another-char  yet-another-char
              'a-short           a-short)))
  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))


(defcstruct s-s-s-double
  (another-short :short)
  (a-s-s-double s-s-double)
  (last-char :char))

(defctype s-s-s-double (:struct s-s-s-double))

(defcvar "the_s_s_s_double" s-s-s-double)

(deftest struct.alignment.4
    (with-foreign-slots
        ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
      (with-foreign-slots
          ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
        (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
          (list 'a-char            a-char
                'a-double          a-double
                'another-char      another-char
                'yet-another-char  yet-another-char
                'a-short           a-short
                'another-short     another-short
                'last-char         last-char))))
  (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5

   another-short 6 last-char 7))

(defcstruct s-double2
  (a-double :double)
  (a-short  :short))

(defctype s-double2 (:struct s-double2))

(defcstruct s-s-double2
  (a-char        :char)
  (a-s-double2   s-double2)
  (another-short :short))

(defctype s-s-double2 (:struct s-s-double2))

(defcvar "the_s_s_double2" s-s-double2)

(deftest struct.alignment.5
    (with-foreign-slots
        ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
      (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
        (list 'a-double       a-double
              'a-short        a-short
              'a-char         a-char
              'another-short  another-short)))
  (a-double 1.0d0 a-short 2 a-char 3 another-short 4))

(defcstruct s-long-long
  (a-long-long :long-long)
  (a-short     :short))

(defctype s-long-long (:struct s-long-long))

(defcstruct s-s-long-long
  (a-char        :char)
  (a-s-long-long s-long-long)
  (another-short :short))

(defctype s-s-long-long (:struct s-s-long-long))

(defcvar "the_s_s_long_long" s-s-long-long)

(deftest struct.alignment.6
    (with-foreign-slots
        ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
      (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
        (list 'a-long-long    a-long-long
              'a-short        a-short
              'a-char         a-char
              'another-short  another-short)))
  (a-long-long 1 a-short 2 a-char 3 another-short 4))

(defcstruct s-s-double3
  (a-s-double2   s-double2)
  (another-short :short))

(defctype s-s-double3 (:struct s-s-double3))

(defcstruct s-s-s-double3
  (a-s-s-double3  s-s-double3)
  (a-char         :char))

(defctype s-s-s-double3 (:struct s-s-s-double3))

(defcvar "the_s_s_s_double3" s-s-s-double3)

(deftest struct.alignment.7
    (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
      (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
        (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
          (list 'a-double      a-double
                'a-short       a-short
                'another-short another-short
                'a-char        a-char))))
  (a-double 1.0d0 a-short 2 another-short 3 a-char 4))

(defcstruct empty-struct)

(defctype empty-struct (:struct empty-struct))

(defcstruct with-empty-struct
  (foo empty-struct)
  (an-int :int))

;; commented out this test because an empty struct is not valid/standard C
;; left the struct declarations anyway because they should be handled
;; gracefuly anyway.

; (defcvar "the_with_empty_struct" with-empty-struct)
;
; (deftest struct.alignment.5
;     (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
;       an-int)
;   42)

;; regression test, setf-ing nested foreign-slot-value forms
;; the setf expander used to return a bogus getter

(defcstruct s1
  (an-int :int))

(defctype s1 (:struct s1))

(defcstruct s2
  (an-s1 s1))

(defctype s2 (:struct s2))

(deftest struct.nested-setf

    (with-foreign-object (an-s2 's2)

      (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
                                's1 'an-int)
            1984)
      (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
                          's1 'an-int))

  1984)

;; regression test, some Lisps were returning 4 instead of 8 for
;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32

(defcstruct s-unsigned-long-long
  (an-unsigned-long-long :unsigned-long-long)
  (a-short               :short))

(defctype s-unsigned-long-long (:struct s-unsigned-long-long))

(defcstruct s-s-unsigned-long-long
  (a-char                 :char)
  (a-s-unsigned-long-long s-unsigned-long-long)
  (another-short          :short))

(defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long))

(defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)

(deftest struct.alignment.8
    (with-foreign-slots
        ((a-char a-s-unsigned-long-long another-short)
         *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
      (with-foreign-slots ((an-unsigned-long-long a-short)
                           a-s-unsigned-long-long s-unsigned-long-long)
        (list 'an-unsigned-long-long  an-unsigned-long-long
              'a-short                a-short
              'a-char                 a-char
              'another-short          another-short)))
  (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4))

;;;# C Struct Wrappers

(define-c-struct-wrapper timeval ())

(define-c-struct-wrapper (timeval2 (:struct timeval)) ()

  (tv-secs))

(defmacro with-example-timeval (var &body body)
  `(with-foreign-object (,var 'timeval)
     (with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
       (setf tv-secs 42 tv-usecs 1984)
       ,@body)))

(deftest struct-wrapper.1
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval :pointer ptr)))
        (values (timeval-tv-secs obj)
                (timeval-tv-usecs obj))))
  42 1984)

(deftest struct-wrapper.2
    (with-example-timeval ptr
      (let ((obj (make-instance 'timeval2 :pointer ptr)))
        (timeval2-tv-secs obj)))
  42)

;;;# Structures as Values

(defcstruct (struct-pair :class pair)

  (a :int)
  (b :int))

(defctype struct-pair-typedef1 (:struct struct-pair))

(defctype struct-pair-typedef2 (:pointer (:struct struct-pair)))

(deftest struct.unparse.1
    (mapcar (alexandria:compose #'cffi::unparse-type #'cffi::parse-type)
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))

  (struct-pair

   (:struct struct-pair)
   struct-pair-typedef1
   struct-pair-typedef2))

(deftest struct.canonicalize.1
    (mapcar #'cffi::canonicalize-foreign-type
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))

  (:pointer

   (:struct struct-pair)
   (:struct struct-pair)

   :pointer))

(deftest struct.canonicalize.2

    (mapcar #'cffi::canonicalize-foreign-type
            '(struct-pair
              (:struct struct-pair)
              struct-pair-typedef1
              struct-pair-typedef2))

  (:pointer
   (:struct struct-pair)
   (:struct struct-pair)

   :pointer))

(defmethod translate-from-foreign (pointer (type pair))

  (with-foreign-slots ((a b) pointer (:struct struct-pair))

    (cons a b)))

(defmethod translate-into-foreign-memory (object (type pair) pointer)

  (with-foreign-slots ((a b) pointer (:struct struct-pair))

    (setf a (car object)
          b (cdr object))))

(defmethod translate-to-foreign (object (type pair))

  (let ((p (foreign-alloc '(:struct struct-pair))))

    (translate-into-foreign-memory object type p)

    (values p t)))

(defmethod free-translated-object (pointer (type pair) freep)
  (when freep
    (foreign-free pointer)))

(deftest struct-values.translation.1
    (multiple-value-bind (p freep)

        (convert-to-foreign '(1 . 2) 'struct-pair)

      (assert freep)
      (unwind-protect

           (convert-from-foreign p 'struct-pair)
        (free-converted-object p 'struct-pair freep)))
  (1 . 2))

(defcfun "pair_pointer_sum" :int

  (p (:pointer (:struct struct-pair))))

#+#:pointer-translation-not-yet-implemented

(deftest struct-values.translation.2
    (pair-pointer-sum '(1 . 2))
  3)

;;; should the return type be something along the lines of
;;; (:pointer (:struct pair) :free t)?

;;; LMH: error on ":free t" option?
(defcfun "alloc_pair" (:pointer (:struct struct-pair))

  (a :int)
  (b :int))

;; bogus: doesn't free() pointer.

#+#:pointer-translation-not-yet-implemented

(deftest struct-values.translation.3
    (alloc-pair 1 2)

  (1 . 2))

(deftest struct-values.translation.mem-ref.1
    (with-foreign-object (p '(:struct struct-pair))
      (setf (mem-ref p '(:struct struct-pair)) '(1 . 2))
      (with-foreign-slots ((a b) p (:struct struct-pair))
        (values (mem-ref p '(:struct struct-pair))
                a
                b)))
  (1 . 2)
  1
  2)

(deftest struct-values.translation.mem-aref.1
    (with-foreign-object (p '(:struct struct-pair) 2)
      (setf (mem-aref p '(:struct struct-pair) 0) '(1 . 2)
            (mem-aref p '(:struct struct-pair) 1) '(3 . 4))
      (values (mem-aref p '(:struct struct-pair) 0)
              (mem-aref p '(:struct struct-pair) 1)))
  (1 . 2)
  (3 . 4))

(defcstruct (struct-pair-default-translate :class pair-default)
  (a :int)
  (b :int))

(deftest struct-values-default.translation.mem-ref.1
    (with-foreign-object (p '(:struct struct-pair-default-translate))
      (setf (mem-ref p '(:struct struct-pair-default-translate)) '(a 1 b 2))
      (with-foreign-slots ((a b) p (:struct struct-pair-default-translate))
        (let ((plist (mem-ref p '(:struct struct-pair-default-translate))))
          (values (getf plist 'a)
                  (getf plist 'b)
                  a
                  b))))
  1
  2
  1
  2)

(defcstruct (struct-pair+double :class pair+double)
  (pr (:struct struct-pair-default-translate))
  (dbl :double))

(deftest struct-values-default.translation.mem-ref.2
    (with-foreign-object (p '(:struct struct-pair+double))
      (setf (mem-ref p '(:struct struct-pair+double)) '(pr (a 4 b 5) dbl 2.5d0))
      (with-foreign-slots ((pr dbl) p (:struct struct-pair+double))
        (let ((plist (mem-ref p '(:struct struct-pair+double))))
          (values (getf (getf plist 'pr) 'a)
                  (getf (getf plist 'pr) 'b)
                  (getf plist 'dbl)))))
  4
  5
  2.5d0)

(defcstruct (struct-pair+1 :class pair+1)

  (p (:pointer (:struct struct-pair)))

  (c :int))

(defctype struct-pair+1 (:struct struct-pair+1))

(defmethod translate-from-foreign (pointer (type pair+1))
  (with-foreign-slots ((p c) pointer struct-pair+1)
    (cons p c)))

(defmethod translate-into-foreign-memory (object (type pair+1) pointer)

  (with-foreign-slots ((c) pointer struct-pair+1)
    (convert-into-foreign-memory (car object)
                                 'struct-pair
                                 (foreign-slot-pointer pointer
                                                       'struct-pair+1
                                                       'p))
    (setf c (cdr object))))

(defmethod translate-to-foreign (object (type pair+1))

  (let ((p (foreign-alloc 'struct-pair+1)))
    (translate-into-foreign-memory object type p)
    (values p t)))

(defmethod free-translated-object (pointer (type pair+1) freep)
  (when freep
    (foreign-free pointer)))

#+#:pointer-translation-not-yet-implemented

(deftest struct-values.translation.ppo.1
    (multiple-value-bind (p freep)
        (convert-to-foreign '((1 . 2) . 3) 'struct-pair+1)
      (assert freep)
      (unwind-protect
           (convert-from-foreign p 'struct-pair+1)
        (free-converted-object p 'struct-pair+1 freep)))
  ((1 . 2) . 3))

#+#:unimplemented
(defcfun "pair_plus_one_sum" :int
  (p (:struct pair+1)))

(defcfun "pair_plus_one_pointer_sum" :int

  (p (:pointer (:struct struct-pair+1))))

#+#:pointer-translation-not-yet-implemented

(deftest struct-values.translation.ppo.2
    (pair-plus-one-pointer-sum '((1 . 2) . 3))
  6)

#+#:unimplemented
(defcfun "make_pair_plus_one" (:struct pair+1)
  (a :int)
  (b :int)
  (c :int))

(defcfun "alloc_pair_plus_one" struct-pair+1
  (a :int)
  (b :int)
  (c :int))

;; bogus: doesn't free() pointer.

#+#:pointer-translation-not-yet-implemented

(deftest struct-values.translation.ppo.3
    (alloc-pair-plus-one 1 2 3)
  ((1 . 2) . 3))

#+#:unimplemented
(defcfun "pair_sum" :int
  (p (:struct pair)))

#+#:unimplemented
(defcfun "make_pair" (:struct pair)
  (a :int)
  (b :int))

#|| ; TODO: load cffi-libffi for these tests to work.

(deftest struct-values.fn.1
    (with-foreign-object (p '(:struct pair))
      (with-foreign-slots ((a b) p (:struct pair))
        (setf a -1 b 2)
        (pair-sum p)))
  1)

(deftest struct-values.fn.2
    (pair-sum '(3 . 5))
  8)

(deftest struct-values.fn.3
    (with-foreign-object (p '(:struct pair))
      (make-pair 7 11 :result-pointer p)
      (with-foreign-slots ((a b) p (:struct pair))
        (cons a b)))
  (7 . 11))

(deftest struct-values.fn.4
    (make-pair 13 17)
  (13 . 17))

||#

(defcstruct single-byte-struct
  (a :uint8))

(deftest bare-struct-types.1
    (eql (foreign-type-size 'single-byte-struct)
         (foreign-type-size '(:struct single-byte-struct)))
  t)

(defctype single-byte-struct-alias (:struct single-byte-struct))

(deftest bare-struct-types.2
    (eql (foreign-type-size 'single-byte-struct-alias)
         (foreign-type-size '(:struct single-byte-struct)))
  t)