1 ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
5 ;;;; This file is part of GNU Guile.
7 ;;;; GNU Guile is free software; you can redistribute it and/or modify it
8 ;;;; under the terms of the GNU Lesser General Public License as published by
9 ;;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;;; your option) any later version.
12 ;;;; GNU Guile is distributed in the hope that it will be useful, but
13 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
15 ;;;; General Public License for more details.
17 ;;;; You should have received a copy of the GNU Lesser General Public License
18 ;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (test-types)
21 #:use-module (test-suite lib)
22 #:use-module (rnrs io ports)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 regex)
25 #:use-module (ice-9 weak-vector)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-9)
28 #:use-module (system foreign)
29 #:use-module (system vm vm)
30 #:use-module (system base types))
32 (define-syntax test-cloneable
34 "Test whether each simple OBJECT is properly decoded."
38 (pass-if-equal (object->string obj) obj
39 (scm->object (object-address obj))))
40 (test-cloneable rest ...)))
44 ;; Test objects that can be directly cloned.
45 (with-test-prefix "clonable objects"
47 #t #f #nil (if #f #f) (eof-object)
49 "narrow string" "wide στρινγ"
52 '(2 . 3) (iota 123) '(1 (two ("three")))
53 #(1 2 3) #(foo bar baz)
55 (make-pointer 123) (make-pointer #xdeadbeef)))
57 ;; Circular objects cannot be compared with 'equal?', so here's their
59 (with-test-prefix "clonable circular objects"
62 (let* ((lst (circular-list 0 1))
63 (result (scm->object (object-address lst))))
69 (define (circular-vector)
70 (let ((v (make-vector 3 'hey)))
74 (let* ((vec (circular-vector))
75 (result (scm->object (object-address vec))))
78 (eq? self result))))))
80 (define-syntax test-inferior-objects
82 "Test whether each OBJECT is recognized and wrapped as an
84 ((_ (object kind sub-kind-pattern) rest ...)
87 (pass-if (object->string obj)
88 (let ((result (scm->object (object-address obj))))
89 (and (inferior-object? result)
90 (eq? 'kind (inferior-object-kind result))
91 (match (inferior-object-sub-kind result)
94 (test-inferior-objects rest ...)))
98 (with-test-prefix "opaque objects"
99 (test-inferior-objects
100 ((make-guardian) smob (? integer?))
101 ((%make-void-port "w") port (? integer?))
102 ((open-input-string "hello") port (? integer?))
103 ((lambda () #t) program _)
104 ((make-weak-vector 3 #t) weak-vector _)
105 ((make-weak-key-hash-table) weak-table _)
106 ((make-weak-value-hash-table) weak-table _)
107 ((make-doubly-weak-hash-table) weak-table _)
108 (#2((1 2 3) (4 5 6)) array _)
109 (#*00000110 bitvector _)
110 ((expt 2 70) bignum _))
113 (let ((fluid (make-fluid)))
114 (inferior-fluid? (scm->object (object-address fluid))))))
116 (define-record-type <some-struct>
119 (x struct-x set-struct-x!)
123 (with-test-prefix "structs"
125 (pass-if-equal "simple struct"
126 '(<some-struct> a b c)
127 (let* ((struct (some-struct 'a 'b 'c))
128 (result (scm->object (object-address struct))))
129 (and (inferior-struct? result)
130 (cons (inferior-struct-name result)
131 (inferior-struct-fields result)))))
133 (pass-if "circular struct"
134 (let ((struct (some-struct #f 'b 'c)))
135 (set-struct-x! struct struct)
136 (let ((result (scm->object (object-address struct))))
137 (and (inferior-struct? result)
138 (eq? (inferior-struct-name result) '<some-struct>)
139 (match (inferior-struct-fields result)
141 (eq? self result)))))))
143 (pass-if "printed circular struct"
145 (string-match "#<struct <some-struct> #0# b c [[:xdigit:]]+>"
146 (let ((struct (some-struct #f 'b 'c)))
147 (set-struct-x! struct struct)
148 (object->string (scm->object (object-address struct)))))))
150 (pass-if "printed deep circular struct"
153 "#<struct <some-struct> \
154 #<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \
156 (let* ((a (some-struct #f 1 2))
157 (b (some-struct a 3 4)))
159 (object->string (scm->object (object-address a))))))))