-;;;; slib.test --- Test suite for Guile's SLIB glue. -*- scheme -*-
-;;;;
-;;;; Copyright 2003, 2004 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
-
-;; These tests are run only if slib is available. slib will need to be
-;; installed (or linked) under the configured guile $prefix.
-;;
-(if (catch #t
- (lambda () (resolve-module '(ice-9 slib)))
- (lambda args #f))
- (begin
-
- (define-module (test-suite test-ice-9-slib)
- #:use-module (test-suite lib)
- #:use-module (ice-9 slib))
-
-
- (with-test-prefix "Configuration"
-
- ;;
- ;; char-code-limit
- ;;
-
- (with-test-prefix "char-code-limit"
- (pass-if "integer" (integer? char-code-limit)))
-
- ;;
- ;; most-positive-fixnum
- ;;
-
- (with-test-prefix "most-positive-fixnum"
- (pass-if "integer" (integer? most-positive-fixnum)))
-
- ;;
- ;; slib:form-feed
- ;;
-
- (with-test-prefix "slib:form-feed"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "char" (char? slib:form-feed)))
-
- ;;
- ;; slib:report
- ;;
-
- (with-test-prefix "slib:report"
- (pass-if "exists" (procedure? slib:report)))
-
- ;;
- ;; slib:report-version
- ;;
-
- (with-test-prefix "slib:report-version"
- (pass-if "exists" (procedure? slib:report-version)))
-
- ;;
- ;; slib:tab
- ;;
-
- (with-test-prefix "slib:tab"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "char" (char? slib:tab)))
-
- ;;
- ;; software-type
- ;;
-
- (with-test-prefix "software-type"
- (pass-if "exists" (procedure? software-type))))
-
-
- (with-test-prefix "Input/Output"
-
- ;;
- ;; call-with-open-ports
- ;;
-
- (with-test-prefix "call-with-open-ports"
- (pass-if "exists" (procedure? call-with-open-ports))
-
- (pass-if "close on return"
- (let ((port (open-input-file "/dev/null")))
- (call-with-open-ports port (lambda (port) #f))
- (port-closed? port))))
-
- ;;
- ;; delete-file
- ;;
-
- ;; in guile 1.6.4 and earlier delete-file didn't match the slib spec
- (with-test-prefix "delete-file"
- (pass-if "non existant file"
- (eq? #f (delete-file "nosuchfile")))
- (pass-if "existing file"
- (call-with-output-file "slibtest.tmp" noop)
- (eq? #t (delete-file "slibtest.tmp"))))
-
- ;;
- ;; output-port-height
- ;;
-
- (with-test-prefix "output-port-height"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? output-port-height)))
-
- ;;
- ;; output-port-width
- ;;
-
- (with-test-prefix "output-port-width"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? output-port-width)))
-
- ;;
- ;; open-file
- ;;
-
- ;; this style open-file is only a requirement in slib 3a1 and up, but
- ;; we provide it always
- (with-test-prefix "open-file"
- (pass-if "r" (port? (open-file "/dev/null" 'r)))
- (pass-if "rb" (port? (open-file "/dev/null" 'rb)))
- (pass-if "w" (port? (open-file "/dev/null" 'w)))
- (pass-if "wb" (port? (open-file "/dev/null" 'wb)))))
-
-
- (with-test-prefix "System stuff"
-
- ;;
- ;; browse-url
- ;;
-
- (with-test-prefix "browse-url"
- (pass-if "exists" (procedure? browse-url)))
-
- ;;
- ;; slib:error
- ;;
-
- (with-test-prefix "slib:error"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:error)))
-
- ;;
- ;; slib:eval
- ;;
-
- (with-test-prefix "slib:eval"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:eval)))
-
- ;;
- ;; slib:eval-load
- ;;
-
- (with-test-prefix "slib:eval-load"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:eval-load)))
-
- ;;
- ;; slib:exit
- ;;
-
- (with-test-prefix "slib:exit"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:exit)))
-
- ;;
- ;; slib:load
- ;;
-
- (with-test-prefix "slib:load"
- (pass-if "exists" (procedure? slib:load)))
-
- ;;
- ;; slib:load-source
- ;;
-
- (with-test-prefix "slib:load-source"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:load-source)))
-
- ;;
- ;; slib:warn
- ;;
-
- (with-test-prefix "slib:warn"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? slib:warn))))
-
-
- (with-test-prefix "Miscellany"
-
- ;;
- ;; identity
- ;;
-
- (with-test-prefix "identity"
- (pass-if "exists" (procedure? identity)))
-
- (with-test-prefix "Legacy"
-
- ;;
- ;; nil
- ;;
-
- ;; in guile 1.6.4 and earlier this was missing
- (with-test-prefix "nil"
- (pass-if "value" (eq? #f nil)))
-
- ;;
- ;; t
- ;;
-
- ;; in guile 1.6.4 and earlier this was missing
- (with-test-prefix "t"
- (pass-if "value" (eq? #t t)))))
-
-
- ;;
- ;; rev2-procedures
- ;;
-
- ;; in guile 1.6.4 the 'rev2-procedures feature we defined claimed
- ;; these existed, but they didn't
- (with-test-prefix "rev2-procedures"
- (require 'rev2-procedures)
- (pass-if "-1+" (procedure? -1+))
- (pass-if "<?" (procedure? <?))
- (pass-if "<=?" (procedure? <=?))
- (pass-if "=?" (procedure? =?))
- (pass-if ">?" (procedure? >?))
- (pass-if ">=?" (procedure? >=?)))
-
-
- ;;
- ;; system
- ;;
-
- ;; in guile 1.6.4 and earlier system didn't match the slib spec
- (with-test-prefix "system"
- (pass-if "exit 0" (= 0 (system "exit 0")))
- (pass-if "exit 1" (= 1 (system "exit 1")))
- (pass-if "exit 99" (= 99 (system "exit 99"))))
-
-
- (with-test-prefix "Time"
-
- ;;
- ;; difftime
- ;;
-
- (with-test-prefix "difftime"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? difftime)))
-
- ;;
- ;; offset-time
- ;;
-
- (with-test-prefix "offset-time"
- ;; in guile 1.6.4 this wasn't exported
- (pass-if "exists" (procedure? offset-time))))
-
-
- (require 'array)
- (with-test-prefix "array"
-
- ;;
- ;; create-array
- ;;
-
- ;; create-array isn't in old slib, but when it exists it should work
- (if (defined? 'create-array)
- (with-test-prefix "create-array"
- (pass-if "As32 create"
- (array? (create-array (As32 0) '(0 1)))))))))
HCoop / bpt / guile.git / blobdiff