From 08ea3794d24edd13924054fe0f4a840a40e2451a Mon Sep 17 00:00:00 2001
From: Kevin Ryde <user42@zip.com.au>
Date: Wed, 7 Mar 2007 22:14:46 +0000
Subject: [PATCH] (make-struct): Exercise the error check on tail array size !=
 0 when layout spec doesn't have tail array. (make-vtable): Exercise this.

---
 test-suite/tests/structs.test | 44 ++++++++++++++++++++++++++++++++++-
 1 file changed, 43 insertions(+), 1 deletion(-)

diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 5c2131835..127115eb2 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -102,6 +102,13 @@
 	      (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 
 
+;;
+;; make-struct
+;;
+
+(define exception:bad-tail
+  (cons 'misc-error "tail array not allowed unless"))
+
 (with-test-prefix "make-struct"
 
   ;; in guile 1.8.1 and earlier, this caused an error throw out of an
@@ -111,7 +118,42 @@
   (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
     (let* ((vv (make-vtable-vtable "" 0))
 	   (v  (make-struct vv 0 (make-struct-layout "uw"))))
-      (make-struct v 0 'x))))
+      (make-struct v 0 'x)))
+
+  ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
+  ;; on a tail array being created without an R/W/O type for it.  This left
+  ;; it uninitialized by scm_struct_init(), resulting in garbage getting
+  ;; into an SCM when struct-ref read it (and attempting to print a garbage
+  ;; SCM can cause a segv).
+  ;;
+  (pass-if-exception "no R/W/O for tail array" exception:bad-tail
+    (let* ((vv (make-vtable-vtable "" 0))
+	   (v  (make-struct vv 0 (make-struct-layout "pw"))))
+      (make-struct v 123 'x))))
+
+;;
+;; make-vtable
+;;
+
+(with-test-prefix "make-vtable"
+
+  (pass-if "without printer"
+    (let* ((vtable (make-vtable "pwpr"))
+	   (struct (make-struct vtable 0 'x 'y)))
+      (and (eq? 'x (struct-ref struct 0))
+	   (eq? 'y (struct-ref struct 1)))))
+
+  (pass-if "with printer"
+    (let ()
+      (define (print struct port)
+	(display "hello" port))
+	
+      (let* ((vtable (make-vtable "pwpr" print))
+	     (struct (make-struct vtable 0 'x 'y))
+	     (str    (call-with-output-string
+		      (lambda (port)
+			(display struct port)))))
+	 (equal? str "hello")))))
 
 
 ;;; Local Variables: