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, 2007, 2009 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 (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
  86 (with-test-prefix "equal?"
  87
  88   (pass-if "simple structs"
  89      (let* ((vtable (make-vtable "pr"))
  90             (s1     (make-struct vtable 0 "hello"))
  91             (s2     (make-struct vtable 0 "hello")))
  92        (equal? s1 s2)))
  93
  94   (pass-if "more complex structs"
  95      (let ((first (make-ball red (string-copy "Bob")))
  96            (second (make-ball red (string-copy "Bob"))))
  97        (equal? first second)))
  98
  99   (pass-if "not-equal?"
 100      (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
 101               (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
 102
 103
 104 ;;
 105 ;; make-struct
 106 ;;
 107
 108 (define exception:bad-tail
 109   (cons 'misc-error "tail array not allowed unless"))
 110
 111 (with-test-prefix "make-struct"
 112
 113   ;; in guile 1.8.1 and earlier, this caused an error throw out of an
 114   ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
 115   ;; the program
 116   ;;
 117   (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
 118     (let* ((vv (make-vtable-vtable "" 0))
 119            (v  (make-struct vv 0 (make-struct-layout "uw"))))
 120       (make-struct v 0 'x)))
 121
 122   ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
 123   ;; on a tail array being created without an R/W/O type for it.  This left
 124   ;; it uninitialized by scm_struct_init(), resulting in garbage getting
 125   ;; into an SCM when struct-ref read it (and attempting to print a garbage
 126   ;; SCM can cause a segv).
 127   ;;
 128   (pass-if-exception "no R/W/O for tail array" exception:bad-tail
 129     (let* ((vv (make-vtable-vtable "" 0))
 130            (v  (make-struct vv 0 (make-struct-layout "pw"))))
 131       (make-struct v 123 'x))))
 132
 133 ;;
 134 ;; make-vtable
 135 ;;
 136
 137 (with-test-prefix "make-vtable"
 138
 139   (pass-if "without printer"
 140     (let* ((vtable (make-vtable "pwpr"))
 141            (struct (make-struct vtable 0 'x 'y)))
 142       (and (eq? 'x (struct-ref struct 0))
 143            (eq? 'y (struct-ref struct 1)))))
 144
 145   (pass-if "with printer"
 146     (let ()
 147       (define (print struct port)
 148         (display "hello" port))
 149
 150       (let* ((vtable (make-vtable "pwpr" print))
 151              (struct (make-struct vtable 0 'x 'y))
 152              (str    (call-with-output-string
 153                       (lambda (port)
 154                         (display struct port)))))
 155          (equal? str "hello")))))
 156
 157
 158 ;;; Local Variables:
 159 ;;; coding: latin-1
 160 ;;; End: