mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-03 21:30:29 +02:00
94 lines
2.8 KiB
Scheme
94 lines
2.8 KiB
Scheme
;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
|
||
;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
|
||
;;;;
|
||
;;;; Copyright (C) 2006 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,
|
||
;;;; 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
|
||
|
||
(use-modules (test-suite lib))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Struct example taken from the reference manual (by Tom Lord).
|
||
;;;
|
||
|
||
(define ball-root (make-vtable-vtable "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)
|
||
|
||
;; end of the vtable tower
|
||
(eq? (struct-vtable ball-root) ball-root)))
|
||
|
||
(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 "equal?"
|
||
(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 "Bill"))
|
||
(equal? (make-ball red "Bob") (make-ball red "Bill"))))))
|
||
|
||
|