(no subject)

[Matthias Koeppe]

Return-path: <address@hidden>
Received: from mkoeppe by rotehorn.math.uni-magdeburg.de with local (Exim 3.22 
#1 (Debian))
        id 157EJy-0005dV-00; Tue, 05 Jun 2001 12:44:22 +0200
To: address@hidden
Subject: New test-suite items (tests that fail with CVS Guile)
From: Matthias Koeppe <address@hidden>
Date: 05 Jun 2001 12:44:21 +0200
Message-ID: <address@hidden>
Lines: 262
MIME-Version: 1.0
Content-Type: text/plain; charset=iso-8859-1
Content-Transfer-Encoding: quoted-printable
Sender: Matthias Koeppe <address@hidden>

I have prepared a few new items for Guile's test suite. I am sending
fixes for all the failures in separate messages. (The FSF already has
papers from me.)

;;;; format.test --- test suite for Guile's CL-ish format  -*- scheme -*-
;;;; Matthias Koeppe <address@hidden> --- June 2001
;;;;
;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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=3D? (format "~%") "\n"))
  (pass-if "format ~& starts a fresh line"
           (string=3D? (format "~&abc~&~&") "abc\n"))
  (pass-if "format ~& is stateless but works properly across outputs via po=
rt-column"
           (string=3D?
            (with-output-to-string
              (lambda ()
                (display "xyz")
                (format #t "~&abc")
                (format #f "~&")        ; shall have no effect
                (format #t "~&~&")))
            "xyz\nabc\n")))

;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <address@hidden> --- June 2001
;;;;
;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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=3D~A" tz)))
        thunk
        (lambda ()
          (if old-tz
              (putenv (format "TZ=3D~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))))))=20=20

(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
             (=3D (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=3D? 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))=09=20=20=20
  (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 "address@hidden:00" "address@hidden:~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=3D? 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=3D? (date->time-utc
                    (with-tz "CET"
                      (string->date "address@hidden:00" "address@hidden:~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:
=20=20
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <address@hidden> --- June 2001
;;;;
;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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.
;;;;=20
;;;; 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))))
=20=20=20=20=20=20
=20=20=20=20


Finally, here is a patch against `ports.test' which adds tests whether
port-line and port-column work for output ports.

Index: test-suite/tests/ports.test
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /cvs/guile/guile-core/test-suite/tests/ports.test,v
retrieving revision 1.25
diff -u -r1.25 ports.test
--- test-suite/tests/ports.test 2001/04/25 23:13:51     1.25
+++ test-suite/tests/ports.test 2001/06/05 08:33:56
@@ -380,6 +380,36 @@
      "He who receives an idea from me, receives instruction"
      15)))
=20
+;; Test port-line and port-column for output ports
+
+(define (test-output-line-counter text final-column)
+  (with-test-prefix "port-line and port-column for output ports"
+    (let ((port (open-output-string)))
+      (pass-if "at beginning of input"
+              (and (=3D (port-line port) 0)
+                   (=3D (port-column port) 0)))
+      (write-char #\x port)
+      (pass-if "after writing one character"
+              (and (=3D (port-line port) 0)
+                   (=3D (port-column port) 1)))
+      (write-char #\newline port)
+      (pass-if "after writing first newline char"
+              (and (=3D (port-line port) 1)
+                   (=3D (port-column port) 0)))
+      (display text port)
+      (pass-if "line count is 5 at end"
+              (=3D (port-line port) 5))
+      (pass-if "column is correct at end"
+              (=3D (port-column port) final-column)))))
+
+(test-output-line-counter
+ (string-append "He who receives an idea from me, receives instruction\n"
+               "himself without lessening mine; as he who lights his\n"
+               "taper at mine, receives light without darkening me.\n"
+               "  --- Thomas Jefferson\n"
+               "no newline here")
+ 15)
+
 
 ;;;; testing read-delimited and friends
=20
=20

--=20
Matthias K=F6ppe -- http://www.math.uni-magdeburg.de/~mkoeppe