mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
New files. Thanks to Matthias Köppe!
This commit is contained in:
Marius Vollmer
parent
2aebf10d73
commit
025f75b48f
3 changed files with 201 additions and 0 deletions
39
test-suite/tests/format.test
Normal file
39
test-suite/tests/format.test
Normal file
|
|
@ -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")))
|
||||
29
test-suite/tests/optargs.test
Normal file
29
test-suite/tests/optargs.test
Normal file
|
|
@ -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))))
|
||||
133
test-suite/tests/srfi-19.test
Normal file
133
test-suite/tests/srfi-19.test
Normal file
|
|
@ -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:
|
||||
Loading…
Add table
Add a link
Reference in a new issue