test-suite/tests/structs.test

   1 ;;;; structs.test --- Test suite for Guile's structures.   -*- Scheme -*-
   2 ;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
   3 ;;;;
   4 ;;;; Copyright (C) 2006 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (use-modules (test-suite lib))
  22
  23
  24 \f
  25 ;;;
  26 ;;; Struct example taken from the reference manual (by Tom Lord).
  27 ;;;
  28
  29 (define ball-root (make-vtable-vtable "pr" 0))
  30
  31 (define (make-ball-type ball-color)
  32   (make-struct ball-root 0
  33                (make-struct-layout "pw")
  34                (lambda (ball port)
  35                  (format port "#<a ~A ball owned by ~A>"
  36                          (color ball)
  37                          (owner ball)))
  38                ball-color))
  39
  40 (define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
  41 (define (owner ball) (struct-ref ball 0))
  42 (define (set-owner! ball owner) (struct-set! ball 0 owner))
  43
  44 (define red (make-ball-type 'red))
  45 (define green (make-ball-type 'green))
  46
  47 (define (make-ball type owner) (make-struct type 0 owner))
  48
  49
  50 \f
  51 ;;;
  52 ;;; Test suite.
  53 ;;;
  54
  55 (with-test-prefix "low-level struct procedures"
  56
  57   (pass-if "constructors"
  58      (and (struct-vtable? ball-root)
  59           (struct-vtable? red)
  60           (struct-vtable? green)))
  61
  62   (pass-if "vtables"
  63      (and (eq? (struct-vtable red) ball-root)
  64           (eq? (struct-vtable green) ball-root)
  65           (eq? (struct-vtable (make-ball red "Bob")) red)
  66
  67           ;; end of the vtable tower
  68           (eq? (struct-vtable ball-root) ball-root)))
  69
  70   (pass-if-exception "write-access denied"
  71      exception:struct-set!-denied
  72
  73      ;; The first field of instances of BALL-ROOT is read-only.
  74      (struct-set! red vtable-offset-user "blue"))
  75
  76   (pass-if "write-access granted"
  77      (set-owner! (make-ball red "Bob") "Fred")
  78      #t)
  79
  80   (pass-if "struct-set!"
  81      (let ((ball (make-ball green "Bob")))
  82        (set-owner! ball "Bill")
  83        (string=? (owner ball) "Bill")))
  84
  85   (pass-if "equal?"
  86      (let ((first (make-ball red (string-copy "Bob")))
  87            (second (make-ball red (string-copy "Bob"))))
  88        (equal? first second)))
  89
  90   (pass-if "not-equal?"
  91      (not (or (equal? (make-ball red "Bob") (make-ball green "Bill"))
  92               (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
  93
  94