;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
;;;; GNU Guile is free software; you can redistribute it and/or modify it
;;;; under the terms of the GNU Lesser General Public License as published by
;;;; the Free Software Foundation; either version 3 of the License, or (at
;;;; your option) any later version.
;;;;
;;;; GNU Guile is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
;;;; General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public License
;;;; along with this program. If not, see .
(define-module (test-types)
#:use-module (test-suite lib)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 weak-vector)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
#:use-module (system vm vm)
#:use-module (system base types))
(define-syntax test-cloneable
(syntax-rules ()
"Test whether each simple OBJECT is properly decoded."
((_ object rest ...)
(begin
(let ((obj object))
(pass-if-equal (object->string obj) obj
(scm->object (object-address obj))))
(test-cloneable rest ...)))
((_)
*unspecified*)))
;; Test objects that can be directly cloned.
(with-test-prefix "clonable objects"
(test-cloneable
#t #f #nil (if #f #f) (eof-object)
42 (expt 2 28) 3.14
"narrow string" "wide στρινγ"
'symbol 'λ
;; NB: keywords are SMOBs.
'(2 . 3) (iota 123) '(1 (two ("three")))
#(1 2 3) #(foo bar baz)
#vu8(255 254 253)
(make-pointer 123) (make-pointer #xdeadbeef)))
;; Circular objects cannot be compared with 'equal?', so here's their
;; home.
(with-test-prefix "clonable circular objects"
(pass-if "list"
(let* ((lst (circular-list 0 1))
(result (scm->object (object-address lst))))
(match result
((0 1 . self)
(eq? self result)))))
(pass-if "vector"
(define (circular-vector)
(let ((v (make-vector 3 'hey)))
(vector-set! v 2 v)
v))
(let* ((vec (circular-vector))
(result (scm->object (object-address vec))))
(match result
(#('hey 'hey self)
(eq? self result))))))
(define-syntax test-inferior-objects
(syntax-rules ()
"Test whether each OBJECT is recognized and wrapped as an
'inferior-object'."
((_ (object kind sub-kind-pattern) rest ...)
(begin
(let ((obj object))
(pass-if (object->string obj)
(let ((result (scm->object (object-address obj))))
(and (inferior-object? result)
(eq? 'kind (inferior-object-kind result))
(match (inferior-object-sub-kind result)
(sub-kind-pattern #t)
(_ #f))))))
(test-inferior-objects rest ...)))
((_)
*unspecified*)))
(with-test-prefix "opaque objects"
(test-inferior-objects
((make-guardian) smob (? integer?))
(#:keyword smob (? integer?))
((%make-void-port "w") port (? integer?))
((open-input-string "hello") port (? integer?))
((lambda () #t) program _)
((the-vm) vm _)
((make-variable 'foo) variable _)
((make-weak-vector 3 #t) weak-vector _)
((make-hash-table) hash-table _)
((make-weak-key-hash-table) hash-table _)
((make-weak-value-hash-table) hash-table _)
((make-doubly-weak-hash-table) hash-table _)
(#2((1 2 3) (4 5 6)) array _)
(#*00000110 bitvector _)
((expt 2 70) bignum _))
(pass-if "fluid"
(let ((fluid (make-fluid)))
(inferior-fluid? (scm->object (object-address fluid))))))
(define-record-type
(some-struct x y z)
some-struct?
(x struct-x set-struct-x!)
(y struct-y)
(z struct-z))
(with-test-prefix "structs"
(pass-if-equal "simple struct"
'( a b c)
(let* ((struct (some-struct 'a 'b 'c))
(result (scm->object (object-address struct))))
(and (inferior-struct? result)
(cons (inferior-struct-name result)
(inferior-struct-fields result)))))
(pass-if "circular struct"
(let ((struct (some-struct #f 'b 'c)))
(set-struct-x! struct struct)
(let ((result (scm->object (object-address struct))))
(and (inferior-struct? result)
(eq? (inferior-struct-name result) ')
(match (inferior-struct-fields result)
((self 'b 'c)
(eq? self result)))))))
(pass-if "printed circular struct"
(->bool
(string-match "# #0# b c [[:xdigit:]]+>"
(let ((struct (some-struct #f 'b 'c)))
(set-struct-x! struct struct)
(object->string (scm->object (object-address struct)))))))
(pass-if "printed deep circular struct"
(->bool
(string-match
"# \
# #-1# 3 4 [[:xdigit:]]+> \
1 2 [[:xdigit:]]+>"
(let* ((a (some-struct #f 1 2))
(b (some-struct a 3 4)))
(set-struct-x! a b)
(object->string (scm->object (object-address a))))))))