test-suite/tests/structs.test

   1 ;;;; structs.test --- Structures.      -*- mode: scheme; coding: utf-8; -*-
   2 ;;;; Ludovic Courtès <ludo@gnu.org>, 2006-06-12.
   3 ;;;;
   4 ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library 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 GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite test-structs)
  21   :use-module (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
  30   (make-vtable (string-append standard-vtable-fields "pr") 0))
  31
  32 (define (make-ball-type ball-color)
  33   (make-struct ball-root 0
  34                (make-struct-layout "pw")
  35                (lambda (ball port)
  36                  (format port "#<a ~A ball owned by ~A>"
  37                          (color ball)
  38                          (owner ball)))
  39                ball-color))
  40
  41 (define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
  42 (define (owner ball) (struct-ref ball 0))
  43 (define (set-owner! ball owner) (struct-set! ball 0 owner))
  44
  45 (define red (make-ball-type 'red))
  46 (define green (make-ball-type 'green))
  47
  48 (define (make-ball type owner) (make-struct type 0 owner))
  49
  50
  51 \f
  52 ;;;
  53 ;;; Test suite.
  54 ;;;
  55
  56 (with-test-prefix "low-level struct procedures"
  57
  58   (pass-if "constructors"
  59      (and (struct-vtable? ball-root)
  60           (struct-vtable? red)
  61           (struct-vtable? green)))
  62
  63   (pass-if "vtables"
  64      (and (eq? (struct-vtable red) ball-root)
  65           (eq? (struct-vtable green) ball-root)
  66           (eq? (struct-vtable (make-ball red "Bob")) red)
  67           (eq? (struct-vtable ball-root) <standard-vtable>)
  68
  69           ;; end of the vtable tower
  70           (eq? (struct-vtable <standard-vtable>) <standard-vtable>)))
  71
  72   (pass-if-exception "write-access denied"
  73      exception:struct-set!-denied
  74
  75      ;; The first field of instances of BALL-ROOT is read-only.
  76      (struct-set! red vtable-offset-user "blue"))
  77
  78   (pass-if "write-access granted"
  79      (set-owner! (make-ball red "Bob") "Fred")
  80      #t)
  81
  82   (pass-if "struct-set!"
  83      (let ((ball (make-ball green "Bob")))
  84        (set-owner! ball "Bill")
  85        (string=? (owner ball) "Bill")))
  86
  87   (pass-if "struct-ref"
  88      (let ((ball (make-ball red "Alice")))
  89        (equal? (struct-ref ball 0) "Alice")))
  90
  91   (pass-if "struct-set!"
  92      (let* ((v (make-vtable "pw"))
  93             (s (make-struct v 0))
  94             (r (struct-set! s 0 'a)))
  95        (eq? r
  96             (struct-ref s 0)
  97             'a)))
  98
  99   (pass-if-exception "struct-ref out-of-range"
 100      exception:out-of-range
 101      (let* ((v (make-vtable "prpr"))
 102             (s (make-struct v 0 'a 'b)))
 103        (struct-ref s 2)))
 104
 105   (pass-if-exception "struct-set! out-of-range"
 106      exception:out-of-range
 107      (let* ((v (make-vtable "pwpw"))
 108             (s (make-struct v 0 'a 'b)))
 109        (struct-set! s 2 'c))))
 110
 111 \f
 112 (with-test-prefix "equal?"
 113
 114   (pass-if "simple structs"
 115      (let* ((vtable (make-vtable "pr"))
 116             (s1     (make-struct vtable 0 "hello"))
 117             (s2     (make-struct vtable 0 "hello")))
 118        (equal? s1 s2)))
 119
 120   (pass-if "more complex structs"
 121      (let ((first (make-ball red (string-copy "Bob")))
 122            (second (make-ball red (string-copy "Bob"))))
 123        (equal? first second)))
 124
 125   (pass-if "not-equal?"
 126      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
 127               (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 128
 129 \f
 130 (with-test-prefix "hash"
 131
 132   (pass-if "simple structs"
 133     (let* ((v  (make-vtable "pr"))
 134            (s1 (make-struct v 0 "hello"))
 135            (s2 (make-struct v 0 "hello")))
 136       (= (hash s1 7777) (hash s2 7777))))
 137
 138   (pass-if "different structs"
 139     (let* ((v  (make-vtable "pr"))
 140            (s1 (make-struct v 0 "hello"))
 141            (s2 (make-struct v 0 "world")))
 142       (or (not (= (hash s1 7777) (hash s2 7777)))
 143           (throw 'unresolved))))
 144
 145   (pass-if "different struct types"
 146     (let* ((v1 (make-vtable "pr"))
 147            (v2 (make-vtable "pr"))
 148            (s1 (make-struct v1 0 "hello"))
 149            (s2 (make-struct v2 0 "hello")))
 150       (or (not (= (hash s1 7777) (hash s2 7777)))
 151           (throw 'unresolved))))
 152
 153   (pass-if "more complex structs"
 154     (let ((s1 (make-ball red (string-copy "Bob")))
 155           (s2 (make-ball red (string-copy "Bob"))))
 156       (= (hash s1 7777) (hash s2 7777))))
 157
 158   (pass-if "struct with weird fields"
 159     (let* ((v  (make-vtable "prurph"))
 160            (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
 161            (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
 162       (= (hash s1 7777) (hash s2 7777))))
 163
 164   (pass-if "cyclic structs"
 165     (let* ((v (make-vtable "pw"))
 166            (a (make-struct v 0 #f))
 167            (b (make-struct v 0 a)))
 168       (struct-set! a 0 b)
 169       (and (hash a 7777) (hash b 7777) #t))))
 170
 171 \f
 172 ;;
 173 ;; make-struct
 174 ;;
 175
 176 (define exception:bad-tail
 177   (cons 'misc-error "tail array not allowed unless"))
 178
 179 (with-test-prefix "make-struct"
 180
 181   ;; in guile 1.8.1 and earlier, this caused an error throw out of an
 182   ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
 183   ;; the program
 184   ;;
 185   (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
 186     (let* ((vv (make-vtable standard-vtable-fields))
 187            (v  (make-struct vv 0 (make-struct-layout "uw"))))
 188       (make-struct v 0 'x)))
 189
 190   ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
 191   ;; on a tail array being created without an R/W/O type for it.  This left
 192   ;; it uninitialized by scm_struct_init(), resulting in garbage getting
 193   ;; into an SCM when struct-ref read it (and attempting to print a garbage
 194   ;; SCM can cause a segv).
 195   ;;
 196   (pass-if-exception "no R/W/O for tail array" exception:bad-tail
 197     (let* ((vv (make-vtable standard-vtable-fields))
 198            (v  (make-struct vv 0 (make-struct-layout "pw"))))
 199       (make-struct v 123 'x))))
 200
 201 ;;
 202 ;; make-vtable
 203 ;;
 204
 205 (with-test-prefix "make-vtable"
 206
 207   (pass-if "without printer"
 208     (let* ((vtable (make-vtable "pwpr"))
 209            (struct (make-struct vtable 0 'x 'y)))
 210       (and (eq? 'x (struct-ref struct 0))
 211            (eq? 'y (struct-ref struct 1)))))
 212
 213   (pass-if "with printer"
 214     (let ()
 215       (define (print struct port)
 216         (display "hello" port))
 217
 218       (let* ((vtable (make-vtable "pwpr" print))
 219              (struct (make-struct vtable 0 'x 'y))
 220              (str    (call-with-output-string
 221                       (lambda (port)
 222                         (display struct port)))))
 223          (equal? str "hello")))))