summaryrefslogtreecommitdiff
path: root/test-suite/tests/structs.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/structs.test')
-rw-r--r--test-suite/tests/structs.test70
1 files changed, 28 insertions, 42 deletions
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 0e3b2417e..c18e42194 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -1,7 +1,7 @@
;;;; 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.
+;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012, 2017 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
@@ -30,13 +30,13 @@
(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))
+ (make-struct/no-tail ball-root
+ (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))
@@ -45,7 +45,7 @@
(define red (make-ball-type 'red))
(define green (make-ball-type 'green))
-(define (make-ball type owner) (make-struct type 0 owner))
+(define (make-ball type owner) (make-struct/no-tail type owner))
@@ -90,7 +90,7 @@
(pass-if "struct-set!"
(let* ((v (make-vtable "pw"))
- (s (make-struct v 0))
+ (s (make-struct/no-tail v))
(r (struct-set! s 0 'a)))
(eq? r
(struct-ref s 0)
@@ -99,13 +99,13 @@
(pass-if-exception "struct-ref out-of-range"
exception:out-of-range
(let* ((v (make-vtable "prpr"))
- (s (make-struct v 0 'a 'b)))
+ (s (make-struct/no-tail v '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)))
+ (s (make-struct/no-tail v 'a 'b)))
(struct-set! s 2 'c))))
@@ -113,8 +113,8 @@
(pass-if "simple structs"
(let* ((vtable (make-vtable "pr"))
- (s1 (make-struct vtable 0 "hello"))
- (s2 (make-struct vtable 0 "hello")))
+ (s1 (make-struct/no-tail vtable "hello"))
+ (s2 (make-struct/no-tail vtable "hello")))
(equal? s1 s2)))
(pass-if "more complex structs"
@@ -131,22 +131,22 @@
(pass-if "simple structs"
(let* ((v (make-vtable "pr"))
- (s1 (make-struct v 0 "hello"))
- (s2 (make-struct v 0 "hello")))
+ (s1 (make-struct/no-tail v "hello"))
+ (s2 (make-struct/no-tail v "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")))
+ (s1 (make-struct/no-tail v "hello"))
+ (s2 (make-struct/no-tail v "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")))
+ (s1 (make-struct/no-tail v1 "hello"))
+ (s2 (make-struct/no-tail v2 "hello")))
(or (not (= (hash s1 7777) (hash s2 7777)))
(throw 'unresolved))))
@@ -157,14 +157,14 @@
(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")))
+ (s1 (make-struct/no-tail v "hello" 123 "invisible-secret1"))
+ (s2 (make-struct/no-tail v "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)))
+ (a (make-struct/no-tail v #f))
+ (b (make-struct/no-tail v a)))
(struct-set! a 0 b)
(and (hash a 7777) (hash b 7777) #t))))
@@ -173,9 +173,6 @@
;; 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
@@ -184,19 +181,8 @@
;;
(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))))
+ (v (make-struct/no-tail vv (make-struct-layout "uw"))))
+ (make-struct/no-tail v 'x))))
;;
;; make-vtable
@@ -206,7 +192,7 @@
(pass-if "without printer"
(let* ((vtable (make-vtable "pwpr"))
- (struct (make-struct vtable 0 'x 'y)))
+ (struct (make-struct/no-tail vtable 'x 'y)))
(and (eq? 'x (struct-ref struct 0))
(eq? 'y (struct-ref struct 1)))))
@@ -216,7 +202,7 @@
(display "hello" port))
(let* ((vtable (make-vtable "pwpr" print))
- (struct (make-struct vtable 0 'x 'y))
+ (struct (make-struct/no-tail vtable 'x 'y))
(str (call-with-output-string
(lambda (port)
(display struct port)))))