1;;;; types.test --- Type tag decoding.      -*- mode: scheme; coding: utf-8; -*-
2;;;;
3;;;; 	Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc.
4;;;;
5;;;; This file is part of GNU Guile.
6;;;;
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.
11;;;;
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.
16;;;;
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/>.
19
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))
31
32(define-syntax test-cloneable
33  (syntax-rules ()
34    "Test whether each simple OBJECT is properly decoded."
35    ((_ object rest ...)
36     (begin
37       (let ((obj object))
38         (pass-if-equal (object->string obj) obj
39           (scm->object (object-address obj))))
40       (test-cloneable rest ...)))
41    ((_)
42     *unspecified*)))
43
44;; Test objects that can be directly cloned.
45(with-test-prefix "clonable objects"
46  (test-cloneable
47   #t #f #nil (if #f #f) (eof-object)
48   42 (expt 2 28) 3.14
49   "narrow string" "wide στρινγ"
50   'symbol 'λ
51   #:keyword #:λ
52   '(2 . 3) (iota 123) '(1 (two ("three")))
53   #(1 2 3) #(foo bar baz)
54   #vu8(255 254 253)
55   (make-pointer 123) (make-pointer #xdeadbeef)))
56
57;; Circular objects cannot be compared with 'equal?', so here's their
58;; home.
59(with-test-prefix "clonable circular objects"
60
61  (pass-if "list"
62    (let* ((lst    (circular-list 0 1))
63           (result (scm->object (object-address lst))))
64      (match result
65        ((0 1 . self)
66         (eq? self result)))))
67
68  (pass-if "vector"
69    (define (circular-vector)
70      (let ((v (make-vector 3 'hey)))
71        (vector-set! v 2 v)
72        v))
73
74    (let* ((vec    (circular-vector))
75           (result (scm->object (object-address vec))))
76      (match result
77        (#('hey 'hey self)
78         (eq? self result))))))
79
80(define-syntax test-inferior-objects
81  (syntax-rules ()
82    "Test whether each OBJECT is recognized and wrapped as an
83'inferior-object'."
84    ((_ (object kind sub-kind-pattern) rest ...)
85     (begin
86       (let ((obj object))
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)
92                    (sub-kind-pattern #t)
93                    (_ #f))))))
94       (test-inferior-objects rest ...)))
95    ((_)
96     *unspecified*)))
97
98(with-test-prefix "opaque objects"
99  (test-inferior-objects
100   ((make-guardian) smob (? integer?))
101   ((%make-void-port "w") port (? inferior-object?))
102   ((open-input-string "hello") port (? inferior-object?))
103   ((lambda () #t) program _)
104   ((make-variable 'foo) variable _)
105   ((make-weak-vector 3 #t) weak-vector _)
106   ((make-weak-key-hash-table) weak-table _)
107   ((make-weak-value-hash-table) weak-table _)
108   ((make-doubly-weak-hash-table) weak-table _)
109   (#2((1 2 3) (4 5 6)) array _)
110   (#*00000110 bitvector _)
111   ((expt 2 70) bignum _)
112   ((make-fluid) fluid _)))
113
114(define-syntax test-inferior-ports
115  (syntax-rules ()
116    "Test whether each OBJECT is a port with the given TYPE-NAME."
117    ((_ (object type-name) rest ...)
118     (begin
119       (pass-if-equal (object->string object)
120           type-name
121         (let ((result (scm->object (object-address object))))
122           (and (eq? 'port (inferior-object-kind result))
123                (let ((type (inferior-object-sub-kind result)))
124                  (and (eq? 'port-type (inferior-object-kind type))
125                       (inferior-object-sub-kind type))))))
126       (test-inferior-ports rest ...)))
127    ((_)
128     *unspecified*)))
129
130(with-test-prefix "ports"
131  (test-inferior-ports
132   ((open-input-file "/dev/null") "file")
133   ((open-output-file "/dev/null") "file")
134   ((open-input-string "the string") "string")
135   ((open-output-string) "string")
136   ((open-bytevector-input-port #vu8(1 2 3 4 5)) "r6rs-bytevector-input-port")
137   ((open-bytevector-output-port) "r6rs-bytevector-output-port")))
138
139(define-record-type <some-struct>
140  (some-struct x y z)
141  some-struct?
142  (x struct-x set-struct-x!)
143  (y struct-y)
144  (z struct-z))
145
146(with-test-prefix "structs"
147
148  (pass-if-equal "simple struct"
149      '(<some-struct> a b c)
150    (let* ((struct (some-struct 'a 'b 'c))
151           (result (scm->object (object-address struct))))
152      (and (inferior-struct? result)
153           (cons (inferior-struct-name result)
154                 (inferior-struct-fields result)))))
155
156  (pass-if "circular struct"
157    (let ((struct (some-struct #f 'b 'c)))
158      (set-struct-x! struct struct)
159      (let ((result (scm->object (object-address struct))))
160        (and (inferior-struct? result)
161             (eq? (inferior-struct-name result) '<some-struct>)
162             (match (inferior-struct-fields result)
163               ((self 'b 'c)
164                (eq? self result)))))))
165
166  (pass-if "printed circular struct"
167    (->bool
168     (string-match "#<struct <some-struct> #0# b c [[:xdigit:]]+>"
169                   (let ((struct (some-struct #f 'b 'c)))
170                     (set-struct-x! struct struct)
171                     (object->string (scm->object (object-address struct)))))))
172
173  (pass-if "printed deep circular struct"
174    (->bool
175     (string-match
176      "#<struct <some-struct> \
177#<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \
1781 2 [[:xdigit:]]+>"
179      (let* ((a (some-struct #f 1 2))
180             (b (some-struct a 3 4)))
181        (set-struct-x! a b)
182        (object->string (scm->object (object-address a))))))))
183