mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
8ac870dee4
* libguile/hash.c (scm_hasher): Call `scm_i_struct_hash' upon
`scm_tcs_struct'.
* libguile/struct.c (scm_i_struct_hash): New function.
* libguile/struct.h (scm_i_struct_hash): New declaration.
* test-suite/tests/structs.test ("hash"): New test prefix.
223 lines
6.8 KiB
Scheme
223 lines
6.8 KiB
Scheme
;;;; structs.test --- Structures. -*- mode: scheme; coding: utf-8; -*-
|
||
;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12.
|
||
;;;;
|
||
;;;; 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
|
||
;;;; 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
|
||
;;;; 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 (string-append standard-vtable-fields "pr") 0))
|
||
|
||
(define (make-ball-type ball-color)
|
||
(make-struct ball-root 0
|
||
(make-struct-layout "pw")
|
||
(lambda (ball port)
|
||
(format port "#<a ~A ball owned by ~A>"
|
||
(color ball)
|
||
(owner ball)))
|
||
ball-color))
|
||
|
||
(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
|
||
(define (owner ball) (struct-ref ball 0))
|
||
(define (set-owner! ball owner) (struct-set! ball 0 owner))
|
||
|
||
(define red (make-ball-type 'red))
|
||
(define green (make-ball-type 'green))
|
||
|
||
(define (make-ball type owner) (make-struct type 0 owner))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Test suite.
|
||
;;;
|
||
|
||
(with-test-prefix "low-level struct procedures"
|
||
|
||
(pass-if "constructors"
|
||
(and (struct-vtable? ball-root)
|
||
(struct-vtable? red)
|
||
(struct-vtable? green)))
|
||
|
||
(pass-if "vtables"
|
||
(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 <standard-vtable>) <standard-vtable>)))
|
||
|
||
(pass-if-exception "write-access denied"
|
||
exception:struct-set!-denied
|
||
|
||
;; The first field of instances of BALL-ROOT is read-only.
|
||
(struct-set! red vtable-offset-user "blue"))
|
||
|
||
(pass-if "write-access granted"
|
||
(set-owner! (make-ball red "Bob") "Fred")
|
||
#t)
|
||
|
||
(pass-if "struct-set!"
|
||
(let ((ball (make-ball green "Bob")))
|
||
(set-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))))
|
||
|
||
|
||
(with-test-prefix "equal?"
|
||
|
||
(pass-if "simple structs"
|
||
(let* ((vtable (make-vtable "pr"))
|
||
(s1 (make-struct vtable 0 "hello"))
|
||
(s2 (make-struct vtable 0 "hello")))
|
||
(equal? s1 s2)))
|
||
|
||
(pass-if "more complex structs"
|
||
(let ((first (make-ball red (string-copy "Bob")))
|
||
(second (make-ball red (string-copy "Bob"))))
|
||
(equal? first second)))
|
||
|
||
(pass-if "not-equal?"
|
||
(not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
|
||
(equal? (make-ball red "Bob") (make-ball red "Bill"))))))
|
||
|
||
|
||
(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))))
|
||
|
||
|
||
;;
|
||
;; 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")))))
|