merge from 1.8 branch

test-suite/ChangeLog

@@ -1,3 +1,19 @@
+2007-03-08  Kevin Ryde  <user42@zip.com.au>
+
+	* tests/structs.test (make-struct): Exercise the error check on tail
+	array size != 0 when layout spec doesn't have tail array.
+	(make-vtable): Exercise this.
+
+2007-02-22  Kevin Ryde  <user42@zip.com.au>
+
+	* tests/structs.test (make-struct): New test of type check on a "u"
+	field, which had been causing an abort().
+
+2007-02-20  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so
+	that it gets into the distribution.
+
 2007-02-19  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so
@@ -18,6 +34,20 @@
 	(SRFI date/time library)[string->date understands days and
 	months]: New test.
 
+2007-01-27  Kevin Ryde  <user42@zip.com.au>
+
+	* tests/ports.test (port-line): Check not truncated to "int" on 64-bit
+	systems.
+
+2007-01-25  Kevin Ryde  <user42@zip.com.au>
+
+	* tests/sort.test (stable-sort): New test, exercising empty list
+	input.  As reported by Ales Hvezda.
+
+	* tests/time.test (gmtime in another thread): Catch #t all errors from
+	gmtime in the thread, since it can be a system error not a scheme
+	out-of-range on 64-bit systems.  Reported by Marijn Schouten.
+
 2007-01-19  Ludovic Courtès  <ludovic.courtes@laas.fr>
 
 	* tests/eval.test (values): New test prefix.  Values are structs,

test-suite/tests/ports.test

@@ -1,7 +1,7 @@
 ;;;; ports.test --- test suite for Guile I/O ports     -*- scheme -*-
 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
 ;;;;
-;;;; 	Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -538,6 +538,17 @@
 	(while (not (eof-object? (read-char port))))
 	(= 8 (port-column port))))))
 
+(with-test-prefix "port-line"
+
+  ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
+  ;; scm_t_port actually holds a long; this restricted the range on 64-bit
+  ;; systems
+  (pass-if "set most-positive-fixnum/2"
+    (let ((n    (quotient most-positive-fixnum 2))
+	  (port (open-output-string)))
+      (set-port-line! port n)
+      (eqv? n (port-line port)))))
+
 ;;;
 ;;; seek
 ;;;

test-suite/tests/sort.test

@@ -1,5 +1,5 @@
 ;;;; sort.test --- tests Guile's sort functions    -*- scheme -*-
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -63,3 +63,16 @@
 	   (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
       (randomize-vector! v 1000)
       (sorted? (stable-sort! v <) <))))
+
+
+;;;
+;;; stable-sort
+;;;
+
+(with-test-prefix "stable-sort"
+
+  ;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a
+  ;; wrong-type-arg exception (where it shouldn't)
+  (pass-if "empty list"
+    (eq? '() (stable-sort '() <))))
+

test-suite/tests/structs.test

@@ -102,6 +102,60 @@
 	      (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
+  ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
+  ;; the program
+  ;;
+  (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)))
+
+  ;; 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:
 ;;; coding: latin-1
 ;;; End:

test-suite/tests/time.test

@@ -1,7 +1,7 @@
 ;;;; time.test --- test suite for Guile's time functions     -*- scheme -*-
 ;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004
 ;;;;
-;;;; 	Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1999, 2004, 2006, 2007 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -34,9 +34,9 @@
 
 		(alarm 5)
 		(false-if-exception (gmtime t))
-		(join-thread (begin-thread (catch 'out-of-range
+		(join-thread (begin-thread (catch #t
-						  (lambda () (gmtime t))
+					     (lambda () (gmtime t))
-						  (lambda args #f))))
+					     (lambda args #f))))
 		(alarm 0)
 		#t))