diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test new file mode 100644 index 000000000..dd740579b --- /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 --- 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 index 000000000..4f356b020 --- /dev/null +++ b/test-suite/tests/optargs.test @@ -0,0 +1,29 @@ +;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- +;;;; Matthias Koeppe --- 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 index 000000000..4065b0556 --- /dev/null +++ b/test-suite/tests/srfi-19.test @@ -0,0 +1,133 @@ +;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- +;;;; Matthias Koeppe --- 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: