test-suite/tests/srfi-38.test

   1 ;;; srfi-38.test --- Tests for SRFI 38.      -*- mode: scheme; -*-
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library. If not, see
  17 ;; <http://www.gnu.org/licenses/>.
  18
  19 ;;; Code:
  20
  21 (define-module (test-srfi-38)
  22   #:use-module (test-suite lib)
  23   #:use-module (srfi srfi-38)
  24   #:use-module (rnrs bytevectors))
  25
  26 (define (shared-structure->string object)
  27   (call-with-output-string
  28     (lambda (port)
  29       (write-with-shared-structure object port))))
  30
  31 (define (roundtrip object)
  32   (call-with-input-string (shared-structure->string object)
  33     (lambda (port)
  34       (read-with-shared-structure port))))
  35
  36 (with-test-prefix "pairs"
  37   (let ((foo (cons 'value-1 #f)))
  38     (set-cdr! foo foo)
  39     (pass-if "writing"
  40       (string=? "#1=(value-1 . #1#)"
  41                 (shared-structure->string foo)))
  42     (pass-if "roundtrip"
  43       (let ((result (roundtrip foo)))
  44         (and (pair? result)
  45              (eq? (car result) 'value-1)
  46              (eq? (cdr result) result))))))
  47
  48 (with-test-prefix "bytevectors"
  49   (let ((vec (vector 0 1 2 3))
  50         (bv (u8-list->bytevector '(42 42))))
  51     (vector-set! vec 0 bv)
  52     (vector-set! vec 2 bv)
  53     (pass-if "roundtrip"
  54       (let ((result (roundtrip vec)))
  55         (and (equal? '#(#vu8(42 42) 1 #vu8(42 42) 3)
  56                      result)
  57              (eq? (vector-ref result 0)
  58                   (vector-ref result 2)))))))
  59
  60 (with-test-prefix "mixed"
  61   (let* ((pair (cons 'a 'b))
  62          (vec (vector 0 pair 2 pair #f)))
  63     (vector-set! vec 4 vec)
  64     (pass-if "roundtrip"
  65       (let ((result (roundtrip vec)))
  66         (and (eq? (vector-ref result 1)
  67                   (vector-ref result 3))
  68              (eq? result (vector-ref result 4)))))))