HCoop / bpt / guile.git / blame
| Commit | Line | Data |
|---|---|---|
| 12708eeb AR |
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))))))) |