#!/bin/sh
exec ${builddir-.}/../run-guile -s "$0" "$@"
!#

(use-modules (test gw-test-child)
             (test gw-test-parent)
	     (test gw-test-aggregating)
             (g-wrap gw standard)
	     (oop goops)
             (unit-test))

(define-class <test-wct> (<test-case>))

(define-method (test-wcp-equal (self <test-wct>))
  "checking that 2 wcp's with the same pointer and wct are equal?..."
  (let* ((obj-1 (gw-test-parent-make-obj "object 1"))
         (same-obj (gw-test-parent-same-obj obj-1)))
    (assert-equal obj-1 same-obj)))

(define-method (test-wcp-not-equal (self <test-wct>))
  "checking that 2 wcp's with the different pointers are not equal?..."
  (let* ((obj-1 (gw-test-parent-make-obj "object 1"))
         (obj-2 (gw-test-parent-make-obj "object 2")))
    (assert-true (not (equal? obj-1 obj-2)))))

(define-method (test-coerce (self <test-wct>))
  "checking that gw:wcp-coerce works for pass-thru..."
  (let* ((obj-1 (gw-test-parent-make-obj "object 1"))
         (coerced-obj (gw:wcp-coerce obj-1 <gw:TestParentObj*>)))
    (assert-equal obj-1 coerced-obj)))

(define-method (test-x-module (self <test-wct>))
  "checking that one module can use another module's types..."
  (let* ((obj-1 (gw-test-parent-make-obj "object 1"))
         (passed-obj (gw-test-child-pass-back-parent-obj obj-1)))
    (assert-equal obj-1 passed-obj)))

(define-method (test-null (self <test-wct>))
  "checking that NULL (#f) is not accepted by default"
  (assert-exception (gw-test-parent-same-obj #f)))

(define (stress-gc)
  ;; Stress the garbage collector to force him to free objects no longer
  ;; referenced.
  (for-each (lambda (i) (gw-test-make-simple-aggregating-obj))
	    (iota 1234))
  (list-copy (map list (iota 12345)))
  (gc) (gc) (gc))

(define-method (test-aggregating-gc-1 (self <test-wct>))
  ;; test that simple allocation and gc works
  (stress-gc))

(define-method (test-aggregating (self <test-wct>))
  (gw-test-make-aggregating-obj (gw-test-make-simple-aggregating-obj))
  ;; Scheme code no longer holds a SMOB to either object.
  ;; Make sure GC can run without a segfault.
  (stress-gc))

(define-method (test-aggregating-with-access (self <test-wct>))
  (let ((obj (gw-test-make-aggregating-obj
	      (gw-test-make-simple-aggregating-obj))))
    ;; Scheme code no longer holds a SMOB to the object aggregated by OBJ.
    ;; Let's force GC and see whether the aggregated object gets freed.
    (stress-gc)
    (assert-true (gw-test-get-aggregated-obj obj))))

(define-method (test-aggregating-gc-2 (self <test-wct>))
  ;; make sure previous test's object gets collected without segv
  (stress-gc))

(define-method (test-aggregating/alt (self <test-wct>))
  ;; Same as above, but using the `/alt' version to create an actual
  ;; aggregating WCP.
  (let ((obj (gw-test-make-aggregating-obj/alt
	      (gw-test-make-simple-aggregating-obj))))
    (stress-gc)
    (assert-true (gw-test-get-aggregated-obj obj))))

(define-method (test-aggregating-gc-3 (self <test-wct>))
  ;; make sure previous test's object gets collected without segv
  (stress-gc))

(exit-with-summary (run-all-defined-test-cases))

;; Local Variables:
;; mode: scheme
;; End:
