1;;;; Scheme implementation of Guile ports -*- scheme -*- 2;;;; 3;;;; Copyright (C) 2016 Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software: you can redistribute it and/or modify 6;;;; it under the terms of the GNU Lesser General Public License as 7;;;; published by the Free Software Foundation, either version 3 of the 8;;;; 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 13;;;; GNU 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(define-module (test-suite test-ports) 20 #:use-module (ice-9 suspendable-ports)) 21 22;; Include tests from ports.test. 23 24(define-syntax import-uses 25 (syntax-rules () 26 ((_) #t) 27 ((_ #:use-module mod . uses) 28 (begin (use-modules mod) (import-uses . uses))))) 29 30(define-syntax include-one 31 (syntax-rules (define-module) 32 ((_ (define-module mod . uses)) 33 (import-uses . uses)) 34 ((_ exp) exp))) 35 36(define-syntax include-tests 37 (lambda (x) 38 (syntax-case x () 39 ((include-tests file) 40 (call-with-input-file (in-vicinity (getenv "TEST_SUITE_DIR") 41 (syntax->datum #'file)) 42 (lambda (port) 43 #`(begin 44 . #,(let lp () 45 (let ((exp (read port))) 46 (if (eof-object? exp) 47 #'() 48 (let ((exp (datum->syntax #'include-tests exp))) 49 #`((include-one #,exp) . #,(lp)))))))) 50 #:guess-encoding #t))))) 51 52(install-suspendable-ports!) 53 54(include-tests "tests/ports.test") 55(include-tests "tests/rdelim.test") 56(include-tests "tests/r6rs-ports.test") 57 58(uninstall-suspendable-ports!) 59