;;;; 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
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.  

;; 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)))))))))