Commit | Line | Data |
---|---|---|
5f4b817d LC |
1 | ;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
e2fafeb9 | 3 | ;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. |
5f4b817d LC |
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) | |
e0da53b4 | 25 | #:use-module (ice-9 weak-vector) |
5f4b817d LC |
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 'λ | |
e2fafeb9 | 51 | #:keyword #:λ |
5f4b817d LC |
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?)) | |
5f4b817d LC |
101 | ((%make-void-port "w") port (? integer?)) |
102 | ((open-input-string "hello") port (? integer?)) | |
103 | ((lambda () #t) program _) | |
e0da53b4 | 104 | ((make-weak-vector 3 #t) weak-vector _) |
475772ea MW |
105 | ((make-weak-key-hash-table) weak-table _) |
106 | ((make-weak-value-hash-table) weak-table _) | |
107 | ((make-doubly-weak-hash-table) weak-table _) | |
e0da53b4 MW |
108 | (#2((1 2 3) (4 5 6)) array _) |
109 | (#*00000110 bitvector _) | |
5f4b817d LC |
110 | ((expt 2 70) bignum _)) |
111 | ||
112 | (pass-if "fluid" | |
113 | (let ((fluid (make-fluid))) | |
114 | (inferior-fluid? (scm->object (object-address fluid)))))) | |
115 | ||
116 | (define-record-type <some-struct> | |
117 | (some-struct x y z) | |
118 | some-struct? | |
119 | (x struct-x set-struct-x!) | |
120 | (y struct-y) | |
121 | (z struct-z)) | |
122 | ||
123 | (with-test-prefix "structs" | |
124 | ||
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))))) | |
132 | ||
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) | |
140 | ((self 'b 'c) | |
141 | (eq? self result))))))) | |
142 | ||
143 | (pass-if "printed circular struct" | |
144 | (->bool | |
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))))))) | |
149 | ||
150 | (pass-if "printed deep circular struct" | |
151 | (->bool | |
152 | (string-match | |
153 | "#<struct <some-struct> \ | |
154 | #<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \ | |
155 | 1 2 [[:xdigit:]]+>" | |
156 | (let* ((a (some-struct #f 1 2)) | |
157 | (b (some-struct a 3 4))) | |
158 | (set-struct-x! a b) | |
159 | (object->string (scm->object (object-address a)))))))) |