-;;;; 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 program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-structs)
:use-module (test-suite lib))
;;; 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
(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
(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)))
(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"
-;;; Local Variables:
-;;; coding: latin-1
-;;; End:
+ (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
+;;
+
+(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 standard-vtable-fields))
+ (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 standard-vtable-fields))
+ (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")))))
HCoop / bpt / guile.git / blobdiff