test-suite/tests/types.test

   1 ;;;; types.test --- Type tag decoding.      -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2014, 2015 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 (? integer?))
 102    ((open-input-string "hello") port (? integer?))
 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
 113   (pass-if "fluid"
 114     (let ((fluid (make-fluid)))
 115       (inferior-fluid? (scm->object (object-address fluid))))))
 116
 117 (define-record-type <some-struct>
 118   (some-struct x y z)
 119   some-struct?
 120   (x struct-x set-struct-x!)
 121   (y struct-y)
 122   (z struct-z))
 123
 124 (with-test-prefix "structs"
 125
 126   (pass-if-equal "simple struct"
 127       '(<some-struct> a b c)
 128     (let* ((struct (some-struct 'a 'b 'c))
 129            (result (scm->object (object-address struct))))
 130       (and (inferior-struct? result)
 131            (cons (inferior-struct-name result)
 132                  (inferior-struct-fields result)))))
 133
 134   (pass-if "circular struct"
 135     (let ((struct (some-struct #f 'b 'c)))
 136       (set-struct-x! struct struct)
 137       (let ((result (scm->object (object-address struct))))
 138         (and (inferior-struct? result)
 139              (eq? (inferior-struct-name result) '<some-struct>)
 140              (match (inferior-struct-fields result)
 141                ((self 'b 'c)
 142                 (eq? self result)))))))
 143
 144   (pass-if "printed circular struct"
 145     (->bool
 146      (string-match "#<struct <some-struct> #0# b c [[:xdigit:]]+>"
 147                    (let ((struct (some-struct #f 'b 'c)))
 148                      (set-struct-x! struct struct)
 149                      (object->string (scm->object (object-address struct)))))))
 150
 151   (pass-if "printed deep circular struct"
 152     (->bool
 153      (string-match
 154       "#<struct <some-struct> \
 155 #<struct <some-struct> #-1# 3 4 [[:xdigit:]]+> \
 156 1 2 [[:xdigit:]]+>"
 157       (let* ((a (some-struct #f 1 2))
 158              (b (some-struct a 3 4)))
 159         (set-struct-x! a b)
 160         (object->string (scm->object (object-address a))))))))