From 3ee7a21884348fb339d3f25b7f8ed10b8127f2c8 Mon Sep 17 00:00:00 2001 From: sperber Date: Fri, 5 Jan 2007 09:46:35 +0000 Subject: [PATCH] Synch SRFI 19 with Scheme 48 (tuebingen/trunk, rev 2031), incorporating various fixes submitted by Emilio Lopes. --- scheme/more-packages.scm | 4 +- scheme/srfi/srfi-19.scm | 171 ++++++++++++++++++--------------------- 2 files changed, 81 insertions(+), 94 deletions(-) diff --git a/scheme/more-packages.scm b/scheme/more-packages.scm index 7e2f46d..f88ce03 100644 --- a/scheme/more-packages.scm +++ b/scheme/more-packages.scm @@ -892,8 +892,8 @@ (subset srfi-1 (reverse!)) srfi-6 srfi-8 - signals - srfi-9) + srfi-9 + srfi-23) (files (srfi srfi-19)))) ; SRFI-20 - withdrawn diff --git a/scheme/srfi/srfi-19.scm b/scheme/srfi/srfi-19.scm index 839bf95..2bea956 100644 --- a/scheme/srfi/srfi-19.scm +++ b/scheme/srfi/srfi-19.scm @@ -145,9 +145,9 @@ (define (tm:time-error caller type value) (if (member type tm:time-error-types) (if value - (error caller "TIME-ERROR type ~S: ~S" type value) - (error caller "TIME-ERROR type ~S" type)) - (error caller "TIME-ERROR unsupported error type ~S" type))) + (error caller "TIME-ERROR type" type value) + (error caller "TIME-ERROR type" type)) + (error caller "TIME-ERROR unsupported error type" type))) ;; A table of leap seconds @@ -159,56 +159,55 @@ ;; & open-input-string ;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat")) -(define (tm:read-tai-utc-data filename) - (define (convert-jd jd) - (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid)) - (define (convert-sec sec) - (inexact->exact sec)) - (let ( (port (open-input-file filename)) - (table '()) ) - (let loop ((line (read-line port))) - (if (not (eof-object? line)) - (begin - (let* ( (data (read (open-input-string (string-append "(" line ")")))) - (year (car data)) - (jd (cadddr (cdr data))) - (secs (cadddr (cdddr data))) ) - (if (>= year 1972) - (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table))) - (loop (read-line port)))))) - table)) +; (define (tm:read-tai-utc-data filename) +; (define (convert-jd jd) +; (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid)) +; (define (convert-sec sec) +; (inexact->exact sec)) +; (let ( (port (open-input-file filename)) +; (table '()) ) +; (let loop ((line (read-line port))) +; (if (not (eof-object? line)) +; (begin +; (let* ( (data (read (open-input-string (string-append "(" line ")")))) +; (year (car data)) +; (jd (cadddr (cdr data))) +; (secs (cadddr (cdddr data))) ) +; (if (>= year 1972) +; (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table))) +; (loop (read-line port)))))) +; table)) ;; each entry is ( utc seconds since epoch . # seconds to add for tai ) ;; note they go higher to lower, and end in 1972. (define tm:leap-second-table - '((1136073600 . 33) - (915148800 . 32) - (867715200 . 31) - (820454400 . 30) - (773020800 . 29) - (741484800 . 28) - (709948800 . 27) - (662688000 . 26) - (631152000 . 25) - (567993600 . 24) - (489024000 . 23) - (425865600 . 22) - (394329600 . 21) - (362793600 . 20) - (315532800 . 19) - (283996800 . 18) - (252460800 . 17) - (220924800 . 16) - (189302400 . 15) - (157766400 . 14) - (126230400 . 13) - (94694400 . 12) - (78796800 . 11) - (63072000 . 10))) + '((915148800 . 32) + (867715200 . 31) + (820454400 . 30) + (773020800 . 29) + (741484800 . 28) + (709948800 . 27) + (662688000 . 26) + (631152000 . 25) + (567993600 . 24) + (489024000 . 23) + (425865600 . 22) + (394329600 . 21) + (362793600 . 20) + (315532800 . 19) + (283996800 . 18) + (252460800 . 17) + (220924800 . 16) + (189302400 . 15) + (157766400 . 14) + (126230400 . 13) + (94694400 . 12) + (78796800 . 11) + (63072000 . 10))) -(define (read-leap-second-table filename) - (set! tm:leap-second-table (tm:read-tai-utc-data filename)) - (values)) +; (define (read-leap-second-table filename) +; (set! tm:leap-second-table (tm:read-tai-utc-data filename)) +; (values)) (define (tm:leap-second-delta utc-seconds) @@ -303,14 +302,9 @@ (define (tm:current-time-thread) (tm:time-error 'current-time 'unsupported-clock-type 'time-thread)) -;; SCSH portability: use cpu-ticks/sec +;; Scheme48 portability: no process time in Scheme48 (regeression from SCSH) (define (tm:current-time-process) - (let ((ticks/s (cpu-ticks/sec))) - (receive (userticks systicks childuserticks childsysticks) (process-times) - (make-time time-process - (* (remainder userticks ticks/s) (/ tm:nano ticks/s)) - (quotient userticks ticks/s))))) - + (tm:time-error 'current-time 'unsupported-clock-type 'time-gc)) ;; SCSH portability: GC time not available in scsh (define (tm:current-time-gc) @@ -633,16 +627,17 @@ (else (tm:char-pos char str (+ index 1) len)))) -(define (tm:split-real r) - (if (integer? r) - (values r 0) - (let ((str (number->string (exact->inexact r)))) - (let ((ppos (tm:char-pos #\. str 0 (string-length str)))) - (if ppos - (values - (string->number (substring str 0 ppos)) - (string->number (substring str (+ ppos 1) (string-length str)))) - (values r 0)))))) +;; return a string representing the decimal expansion of the fractional +;; portion of a number, limited by a specified precision +(define (tm:decimal-expansion r precision) + (let loop ((num (- r (round r))) + (p precision)) + (if (or (= p 0) (= num 0)) + "" + (let* ((num-times-10 (* 10 num)) + (round-num-times-10 (round num-times-10))) + (string-append (number->string (inexact->exact round-num-times-10)) + (loop (- num-times-10 round-num-times-10) (- p 1))))))) ;; gives the seconds/date/month/year (define (tm:decode-julian-day-number jdn) @@ -668,7 +663,7 @@ ;; SCSH portability: use scsh's DATE procedure (define (tm:local-tz-offset) - (date:tz-secs (date))) + 0) ;; FIXME: quick hack ;; special thing -- ignores nanos (define (tm:time->julian-day-number seconds tz-offset) @@ -823,22 +818,21 @@ (define (date->julian-day date) (let ( (nanosecond (date-nanosecond date)) - (second (date-second date)) - (minute (date-minute date)) - (hour (date-hour date)) - (day (date-day date)) - (month (date-month date)) - (year (date-year date)) - (offset (date-zone-offset date)) ) + (second (date-second date)) + (minute (date-minute date)) + (hour (date-hour date)) + (day (date-day date)) + (month (date-month date)) + (year (date-year date)) + (offset (date-zone-offset date)) ) (+ (tm:encode-julian-day-number day month year) (- 1/2) - ;; SCSH portability: use binary / - (+ (/ (/ (+ (* hour 60 60) - (* minute 60) - second - (/ nanosecond tm:nano)) - tm:sid) - (- offset)))))) + (+ (/ (+ (* hour 60 60) + (* minute 60) + second + (/ nanosecond tm:nano) + (- offset)) + tm:sid))))) (define (date->modified-julian-day date) (- (date->julian-day date) @@ -1047,17 +1041,11 @@ (display (tm:padding (date-second date) pad-with 2) port)) - (receive (i f) - ;;; SCSH portability: make use of / binary - (tm:split-real (/ - (date-nanosecond date) - (* tm:nano 1.0))) - (let* ((ns (number->string f)) - (le (string-length ns))) - (if (> le 2) - (begin - (display tm:locale-number-separator port) - (display (substring ns 2 le) port))))))) + (let* ((f (tm:decimal-expansion (/ (date-nanosecond date) tm:nano) 9))) + (if (> (string-length f) 0) + (begin + (display tm:locale-number-separator port) + (display f port)))))) (cons #\h (lambda (date pad-with port) (display (date->string date "~b") port))) (cons #\H (lambda (date pad-with port) @@ -1487,4 +1475,3 @@ (if (tm:date-ok? newdate) newdate (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) -