New files. Thanks to Matthias Köppe!

diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test
new file mode 100644 (file)
index 0000000..dd74057
--- /dev/null
+++ b/test-suite/tests/format.test
@@ -0,0 +1,39 @@
+;;;; format.test --- test suite for Guile's CL-ish format  -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;;   Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(use-modules (test-suite lib)
+            (ice-9 format))
+
+;;; FORMAT Basic Output
+
+(with-test-prefix "format basic output"
+  (pass-if "format ~% produces a new line"
+          (string=? (format "~%") "\n"))
+  (pass-if "format ~& starts a fresh line"
+          (string=? (format "~&abc~&~&") "abc\n"))
+  (pass-if "format ~& is stateless but works properly across outputs via port-column"
+          (string=?
+           (with-output-to-string
+             (lambda ()
+               (display "xyz")
+               (format #t "~&abc")
+               (format #f "~&")        ; shall have no effect
+               (format #t "~&~&")))
+           "xyz\nabc\n")))

diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
new file mode 100644 (file)
index 0000000..4f356b0
--- /dev/null
+++ b/test-suite/tests/optargs.test
@@ -0,0 +1,29 @@
+;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;;   Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(use-modules (test-suite lib)
+            (ice-9 optargs))
+
+(with-test-prefix "optional argument processing"
+  (define* (test-1 #:optional (x 0))
+    (define d 1)                       ; local define
+    #t)
+  (pass-if "local defines work with optional arguments"
+          (false-if-exception (test-1))))

diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test
new file mode 100644 (file)
index 0000000..4065b05
--- /dev/null
+++ b/test-suite/tests/srfi-19.test
@@ -0,0 +1,133 @@
+;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;;   Copyright (C) 2001 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., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+;; SRFI-19 overrides current-date, so we have to do the test in a
+;; separate module, or later tests will fail.
+
+(define-module (test-suite test-srfi-19)
+  :use-module (test-suite lib)
+  :use-module (srfi srfi-19)
+  :use-module (ice-9 format))
+
+(define (with-tz* tz thunk)
+  "Temporarily set the TZ environment variable to the passed string
+value and call THUNK."
+  (let ((old-tz #f))
+    (dynamic-wind
+       (lambda ()
+         (set! old-tz (getenv "TZ"))
+         (putenv (format "TZ=~A" tz)))
+       thunk
+       (lambda ()
+         (if old-tz
+             (putenv (format "TZ=~A" old-tz))
+             (putenv "TZ"))))))
+
+(defmacro with-tz (tz . body)
+  `(with-tz* ,tz (lambda () ,@body)))
+
+(define (test-integral-time-structure date->time)
+  "Test whether the given DATE->TIME procedure creates a time
+structure with integral seconds.  (The seconds shall be maintained as
+integers, or precision may go away silently.  The SRFI-19 reference
+implementation was not OK for Guile in this respect because of Guile's
+incomplete numerical tower implementation.)"
+  (pass-if (format "~A makes integer seconds"
+                  date->time)
+          (exact? (time-second
+                   (date->time (make-date 0 0 0 12 1 6 2001 0))))))  
+
+(define (test-time->date time->date date->time)
+  (pass-if (format "~A works"
+                  time->date)
+          (begin
+            (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
+            #t)))
+
+(define (test-dst time->date date->time)
+  (pass-if (format "~A respects local DST if no TZ-OFFSET given"
+                  time->date)
+          (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
+            ;; on 2001-06-01, there should be two hours zone offset
+            ;; between CET (CEST) and GMT
+            (= (date-zone-offset
+                (with-tz "CET"
+                  (time->date time)))
+               7200))))
+
+(define-macro (test-time-conversion a b)
+  (let* ((a->b-sym (symbol-append a '-> b))
+        (b->a-sym (symbol-append b '-> a)))
+    `(pass-if (format "~A and ~A work and are inverses of each other"
+                     ',a->b-sym ',b->a-sym)
+             (let ((time (make-time ,a 12345 67890123)))
+               (time=? time (,b->a-sym (,a->b-sym time)))))))
+
+(with-test-prefix "SRFI date/time library"
+  ;; check for typos and silly errors
+  (pass-if "date-zone-offset is defined"
+          (and (defined? 'date-zone-offset)
+               date-zone-offset
+               #t))       
+  (pass-if "add-duration is defined"
+          (and (defined? 'add-duration)
+               add-duration
+               #t))
+  (pass-if "(current-time time-tai) works"
+          (begin (current-time time-tai) #t))
+  (test-time-conversion time-utc time-tai)
+  (test-time-conversion time-utc time-monotonic)
+  (test-time-conversion time-tai time-monotonic)
+  (pass-if "string->date works"
+          (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
+                 #t))
+  ;; check for code paths where reals were passed to quotient, which
+  ;; doesn't work in Guile (and is unspecified in R5RS)
+  (test-time->date time-utc->date date->time-utc)
+  (test-time->date time-tai->date date->time-tai)
+  (test-time->date time-monotonic->date date->time-monotonic)
+  (pass-if "Fractional nanoseconds are handled"
+          (begin (make-time time-duration 1000000000.5 0) #t))
+  ;; the seconds in a time shall be maintained as integers, or
+  ;; precision may silently go away
+  (test-integral-time-structure date->time-utc)
+  (test-integral-time-structure date->time-tai)
+  (test-integral-time-structure date->time-monotonic)
+  ;; check for DST and zone related problems
+  (pass-if "date->time-utc is the inverse of time-utc->date"
+          (let ((time (date->time-utc
+                       (make-date 0 0 0 14 1 6 2001 7200))))
+            (time=? time
+                    (date->time-utc (time-utc->date time 7200)))))
+  (test-dst time-utc->date date->time-utc)
+  (test-dst time-tai->date date->time-tai)
+  (test-dst time-monotonic->date date->time-monotonic)
+  (test-dst julian-day->date date->julian-day)
+  (test-dst modified-julian-day->date date->modified-julian-day)
+  (pass-if "string->date respects local DST if no time zone is read"
+          (time=? (date->time-utc
+                   (with-tz "CET"
+                     (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")))
+                  (date->time-utc
+                   (make-date 0 0 0 12 1 6 2001 0)))))
+
+;; Local Variables:
+;; eval: (put 'with-tz 'scheme-indent-function 1)
+;; End: