GOOPS cosmetics

[bpt/guile.git] / test-suite / tests / structs.test

diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index e114abb..0e3b241 100644 (file)
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -1,7 +1,7 @@
-;;;; structs.test --- Test suite for Guile's structures.   -*- Scheme -*-
-;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
+;;;; structs.test --- Structures.      -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12.
 ;;;;
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -26,7 +26,8 @@
 ;;; Struct example taken from the reference manual (by Tom Lord).
 ;;;
 
-(define ball-root (make-vtable-vtable "pr" 0))
+(define ball-root
+  (make-vtable (string-append standard-vtable-fields "pr") 0))
 
 (define (make-ball-type ball-color)
   (make-struct ball-root 0
@@ -63,9 +64,10 @@
      (and (eq? (struct-vtable red) ball-root)
          (eq? (struct-vtable green) ball-root)
          (eq? (struct-vtable (make-ball red "Bob")) red)
+          (eq? (struct-vtable ball-root) <standard-vtable>)
 
          ;; end of the vtable tower
-         (eq? (struct-vtable ball-root) ball-root)))
+         (eq? (struct-vtable <standard-vtable>) <standard-vtable>)))
 
   (pass-if-exception "write-access denied"
      exception:struct-set!-denied
@@ -80,13 +82,37 @@
   (pass-if "struct-set!"
      (let ((ball (make-ball green "Bob")))
        (set-owner! ball "Bill")
-       (string=? (owner ball) "Bill"))))
+       (string=? (owner ball) "Bill")))
 
+  (pass-if "struct-ref"
+     (let ((ball (make-ball red "Alice")))
+       (equal? (struct-ref ball 0) "Alice")))
 
+  (pass-if "struct-set!"
+     (let* ((v (make-vtable "pw"))
+            (s (make-struct v 0))
+            (r (struct-set! s 0 'a)))
+       (eq? r
+            (struct-ref s 0)
+            'a)))
+
+  (pass-if-exception "struct-ref out-of-range"
+     exception:out-of-range
+     (let* ((v (make-vtable "prpr"))
+            (s (make-struct v 0 'a 'b)))
+       (struct-ref s 2)))
+
+  (pass-if-exception "struct-set! out-of-range"
+     exception:out-of-range
+     (let* ((v (make-vtable "pwpw"))
+            (s (make-struct v 0 'a 'b)))
+       (struct-set! s 2 'c))))
+
+\f
 (with-test-prefix "equal?"
 
   (pass-if "simple structs"
-     (let* ((vtable (make-vtable-vtable "pr" 0))
+     (let* ((vtable (make-vtable "pr"))
             (s1     (make-struct vtable 0 "hello"))
             (s2     (make-struct vtable 0 "hello")))
        (equal? s1 s2)))
@@ -100,7 +126,49 @@
      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
              (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 
+\f
+(with-test-prefix "hash"
+
+  (pass-if "simple structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "hello")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "different structs"
+    (let* ((v  (make-vtable "pr"))
+           (s1 (make-struct v 0 "hello"))
+           (s2 (make-struct v 0 "world")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
+
+  (pass-if "different struct types"
+    (let* ((v1 (make-vtable "pr"))
+           (v2 (make-vtable "pr"))
+           (s1 (make-struct v1 0 "hello"))
+           (s2 (make-struct v2 0 "hello")))
+      (or (not (= (hash s1 7777) (hash s2 7777)))
+          (throw 'unresolved))))
 
+  (pass-if "more complex structs"
+    (let ((s1 (make-ball red (string-copy "Bob")))
+          (s2 (make-ball red (string-copy "Bob"))))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "struct with weird fields"
+    (let* ((v  (make-vtable "prurph"))
+           (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
+           (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
+      (= (hash s1 7777) (hash s2 7777))))
+
+  (pass-if "cyclic structs"
+    (let* ((v (make-vtable "pw"))
+           (a (make-struct v 0 #f))
+           (b (make-struct v 0 a)))
+      (struct-set! a 0 b)
+      (and (hash a 7777) (hash b 7777) #t))))
+
+\f
 ;;
 ;; make-struct
 ;;
@@ -115,7 +183,7 @@
   ;; the program
   ;;
   (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
-    (let* ((vv (make-vtable-vtable "" 0))
+    (let* ((vv (make-vtable standard-vtable-fields))
           (v  (make-struct vv 0 (make-struct-layout "uw"))))
       (make-struct v 0 'x)))
 
@@ -126,7 +194,7 @@
   ;; SCM can cause a segv).
   ;;
   (pass-if-exception "no R/W/O for tail array" exception:bad-tail
-    (let* ((vv (make-vtable-vtable "" 0))
+    (let* ((vv (make-vtable standard-vtable-fields))
           (v  (make-struct vv 0 (make-struct-layout "pw"))))
       (make-struct v 123 'x))))
 
@@ -153,8 +221,3 @@
                      (lambda (port)
                        (display struct port)))))
         (equal? str "hello")))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; End: