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