[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SRFI-19 patch, or: strange syncase implications
From: |
Matthias Koeppe |
Subject: |
SRFI-19 patch, or: strange syncase implications |
Date: |
23 May 2001 17:26:28 +0200 |
User-agent: |
Gnus/5.0808 (Gnus v5.8.8) Emacs/20.6 |
I tried to actually use the new SRFI-19 (time/date) module but found
several problems.
1) The implementation expects `quotient' to work on a inexact real
first argument, though R5RS only defines behavior for integer
arguments. Since Guile follows R5RS here, I had to fix a few
calls to `quotient'; see the patch below.
2) For some reason, in the definition of the `date' record type,
`make-date-unnormalized' was made the constructor, but
`make-date' was used everywhere; see the patch below.
3) The implementation uses a simple syntax definition to provide a
syntax for extracting optional arguments, but this seems to cause
breakage. In the patch, I have used (ice-9 optargs) instead of
(ice-9 syncase) for handling optional arguments in order to work
around the problem.
Here is information on how to reproduce the syntax-rules breakage (with
the unpatched srfi-19.scm): Type
(date->string (make-date-unnormalized 0 1 2 3 4 5 6 7) "~Y")
Guile hangs until interrupted. No backtrace is available. Once (I
think I was tracing `priv:date-printer'), I got
"lazy-catch handler did return."
I believe this must be related to the syncase system because the
problems went away when I used (ice-9 optargs) instead of (ice-9
syncase).
Index: srfi/srfi-19.scm
===================================================================
RCS file: /cvs/guile/guile-core/srfi/srfi-19.scm,v
retrieving revision 1.3
diff -u -r1.3 srfi-19.scm
--- srfi/srfi-19.scm 2001/05/23 05:04:55 1.3
+++ srfi/srfi-19.scm 2001/05/23 14:33:25
@@ -27,7 +27,7 @@
;; functions that do more work in a "chunk".
(define-module (srfi srfi-19)
- :use-module (ice-9 syncase)
+ :use-module (ice-9 optargs)
:use-module (srfi srfi-6)
:use-module (srfi srfi-8)
:use-module (srfi srfi-9)
@@ -121,13 +121,6 @@
(cond-expand-provide (current-module) '(srfi-19))
-;; :OPTIONAL is nice
-
-(define-syntax :optional
- (syntax-rules ()
- ((_ val default-value)
- (if (null? val) default-value (car val)))))
-
(define time-tai 'time-tai)
(define time-utc 'time-utc)
(define time-monotonic 'time-monotonic)
@@ -385,8 +378,7 @@
;;(define (priv:current-time-gc)
;; (priv:current-time-ms-time time-gc current-gc-milliseconds))
-(define (current-time . clock-type)
- (let ((clock-type (:optional clock-type time-utc)))
+(define* (current-time #:optional (clock-type time-utc))
(cond
((eq? clock-type time-tai) (priv:current-time-tai))
((eq? clock-type time-utc) (priv:current-time-utc))
@@ -394,14 +386,13 @@
((eq? clock-type time-thread) (priv:current-time-thread))
((eq? clock-type time-process) (priv:current-time-process))
;; ((eq? clock-type time-gc) (priv:current-time-gc))
- (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
+ (else (priv:time-error 'current-time 'invalid-clock-type clock-type))))
;; -- Time Resolution
;; This is the resolution of the clock in nanoseconds.
;; This will be implementation specific.
-(define (time-resolution . clock-type)
- (let ((clock-type (:optional clock-type time-utc)))
+(define* (time-resolution #:optional (clock-type time-utc))
(case clock-type
((time-tai) 1000)
((time-utc) 1000)
@@ -409,7 +400,7 @@
((time-process) priv:ns-per-guile-tick)
;; ((eq? clock-type time-thread) 1000)
;; ((eq? clock-type time-gc) 10000)
- (else (priv:time-error 'time-resolution 'invalid-clock-type
clock-type)))))
+ (else (priv:time-error 'time-resolution 'invalid-clock-type
clock-type))))
;; -- Time comparisons
@@ -574,7 +565,7 @@
;; -- Date Structures
(define-record-type date
- (make-date-unnormalized nanosecond second minute
+ (make-date nanosecond second minute
hour day month
year
zone-offset)
@@ -608,7 +599,7 @@
;; gives the seconds/date/month/year
(define (priv:decode-julian-day-number jdn)
- (let* ((days (truncate jdn))
+ (let* ((days (inexact->exact (truncate jdn)))
(a (+ days 32044))
(b (quotient (+ (* 4 a) 3) 146097))
(c (- a (quotient (* 146097 b) 4)))
@@ -639,11 +630,10 @@
(define (priv:leap-second? second)
(and (assoc second priv:leap-second-table) #t))
-(define (time-utc->date time . tz-offset)
+(define* (time-utc->date time #:optional (offset (priv:local-tz-offset)))
(if (not (eq? (time-type time) time-utc))
(priv:time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
- (leap-second? (priv:leap-second? (+ offset (time-second time))))
+ (let* ((leap-second? (priv:leap-second? (+ offset (time-second time))))
(jdn (priv:time->julian-day-number (if leap-second?
(- (time-second time) 1)
(time-second time))
@@ -651,8 +641,9 @@
(call-with-values (lambda () (priv:decode-julian-day-number jdn))
(lambda (secs date month year)
- (let* ((hours (quotient secs (* 60 60)))
- (rem (remainder secs (* 60 60)))
+ (let* ((int-secs (inexact->exact (floor secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
(minutes (quotient rem 60))
(seconds (remainder rem 60)))
(make-date (time-nanosecond time)
@@ -664,11 +655,10 @@
year
offset))))))
-(define (time-tai->date time . tz-offset)
+(define* (time-tai->date time #:optional (offset (priv:local-tz-offset)))
(if (not (eq? (time-type time) time-tai))
(priv:time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
- (seconds (- (time-second time)
+ (let* ((seconds (- (time-second time)
(priv:leap-second-delta (time-second time))))
(leap-second? (priv:leap-second? (+ offset seconds)))
(jdn (priv:time->julian-day-number (if leap-second?
@@ -692,11 +682,10 @@
offset))))))
;; this is the same as time-tai->date.
-(define (time-monotonic->date time . tz-offset)
+(define* (time-monotonic->date time #:optional (offset (priv:local-tz-offset)))
(if (not (eq? (time-type time) time-monotonic))
(priv:time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (:optional tz-offset (priv:local-tz-offset)))
- (seconds (- (time-second time)
+ (let* ((seconds (- (time-second time)
(priv:leap-second-delta (time-second time))))
(leap-second? (priv:leap-second? (+ offset seconds)))
(jdn (priv:time->julian-day-number (if leap-second?
@@ -791,9 +780,9 @@
(priv:days-before-first-week date day-of-week-starting-week))
7))
-(define (current-date . tz-offset)
+(define* (current-date #:optional (offset (priv:local-tz-offset)))
(time-utc->date (current-time time-utc)
- (:optional tz-offset (priv:local-tz-offset))))
+ offset))
;; given a 'two digit' number, find the year within 50 years +/-
(define (priv:natural-year n)
@@ -876,14 +865,12 @@
(define (julian-day->time-monotonic jdn)
(time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define* (julian-day->date jdn #:optional (offset (priv:local-tz-offset)))
+ (time-utc->date (julian-day->time-utc jdn) offset))
-(define (julian-day->date jdn . tz-offset)
- (let ((offset (:optional tz-offset (priv:local-tz-offset))))
- (time-utc->date (julian-day->time-utc jdn) offset)))
-
-(define (modified-julian-day->date jdn . tz-offset)
- (let ((offset (:optional tz-offset (priv:local-tz-offset))))
- (julian-day->date (+ jdn 4800001/2) offset)))
+(define* (modified-julian-day->date jdn #:optional (offset
(priv:local-tz-offset)))
+ (julian-day->date (+ jdn 4800001/2) offset))
(define (modified-julian-day->time-utc jdn)
(julian-day->time-utc (+ jdn 4800001/2)))
@@ -1142,7 +1129,7 @@
(if (>= index str-len)
(values)
(let ((current-char (string-ref format-string index)))
- (if (not (char=? current-char #\~))
+ (if (not (char=? current-char #\~))
(begin
(display current-char port)
(priv:date-printer date (+ index 1) format-string str-len port))
@@ -1207,11 +1194,11 @@
port))))))))))))
-(define (date->string date . format-string)
- (let ((str-port (open-output-string))
- (fmt-str (:optional format-string "~c")))
- (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
- (get-output-string str-port)))
+(define* (date->string date #:optional (format-string "~c"))
+ (with-output-to-string
+ (lambda ()
+ (priv:date-printer date 0 format-string (string-length format-string)
+ (current-output-port)))))
(define (priv:char->int ch)
(case ch
--
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe
- SRFI-19 patch, or: strange syncase implications,
Matthias Koeppe <=