scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Synch SRFI 19 with Scheme 48 (tuebingen/trunk, rev 2031), 

incorporating various fixes submitted by Emilio Lopes.
This commit is contained in:
sperber 2007-01-05 09:46:35 +00:00
parent d8b1c64044
commit 3ee7a21884
2 changed files with 81 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/more-packages.scm
View File

@ -892,8 +892,8 @@
(subset srfi-1 (reverse!)) (subset srfi-1 (reverse!))
srfi-6 srfi-6
srfi-8 srfi-8
signals srfi-9
srfi-9) srfi-23)
(files (srfi srfi-19)))) (files (srfi srfi-19))))
; SRFI-20 - withdrawn ; SRFI-20 - withdrawn

171
scheme/srfi/srfi-19.scm
View File

@ -145,9 +145,9 @@
(define (tm:time-error caller type value) (define (tm:time-error caller type value)
(if (member type tm:time-error-types) (if (member type tm:time-error-types)
(if value (if value
(error caller "TIME-ERROR type ~S: ~S" type value) (error caller "TIME-ERROR type" type value)
(error caller "TIME-ERROR type ~S" type)) (error caller "TIME-ERROR type" type))
(error caller "TIME-ERROR unsupported error type ~S" type))) (error caller "TIME-ERROR unsupported error type" type)))
;; A table of leap seconds ;; A table of leap seconds
@ -159,56 +159,55 @@
;; & open-input-string ;; & open-input-string
;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat")) ;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat"))
(define (tm:read-tai-utc-data filename) ; (define (tm:read-tai-utc-data filename)
(define (convert-jd jd) ; (define (convert-jd jd)
(* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid)) ; (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid))
(define (convert-sec sec) ; (define (convert-sec sec)
(inexact->exact sec)) ; (inexact->exact sec))
(let ( (port (open-input-file filename)) ; (let ( (port (open-input-file filename))
(table '()) ) ; (table '()) )
(let loop ((line (read-line port))) ; (let loop ((line (read-line port)))
(if (not (eof-object? line)) ; (if (not (eof-object? line))
(begin ; (begin
(let* ( (data (read (open-input-string (string-append "(" line ")")))) ; (let* ( (data (read (open-input-string (string-append "(" line ")"))))
(year (car data)) ; (year (car data))
(jd (cadddr (cdr data))) ; (jd (cadddr (cdr data)))
(secs (cadddr (cdddr data))) ) ; (secs (cadddr (cdddr data))) )
(if (>= year 1972) ; (if (>= year 1972)
(set! table (cons (cons (convert-jd jd) (convert-sec secs)) table))) ; (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table)))
(loop (read-line port)))))) ; (loop (read-line port))))))
table)) ; table))
;; each entry is ( utc seconds since epoch . # seconds to add for tai ) ;; each entry is ( utc seconds since epoch . # seconds to add for tai )
;; note they go higher to lower, and end in 1972. ;; note they go higher to lower, and end in 1972.
(define tm:leap-second-table (define tm:leap-second-table
'((1136073600 . 33) '((915148800 . 32)
(915148800 . 32) (867715200 . 31)
(867715200 . 31) (820454400 . 30)
(820454400 . 30) (773020800 . 29)
(773020800 . 29) (741484800 . 28)
(741484800 . 28) (709948800 . 27)
(709948800 . 27) (662688000 . 26)
(662688000 . 26) (631152000 . 25)
(631152000 . 25) (567993600 . 24)
(567993600 . 24) (489024000 . 23)
(489024000 . 23) (425865600 . 22)
(425865600 . 22) (394329600 . 21)
(394329600 . 21) (362793600 . 20)
(362793600 . 20) (315532800 . 19)
(315532800 . 19) (283996800 . 18)
(283996800 . 18) (252460800 . 17)
(252460800 . 17) (220924800 . 16)
(220924800 . 16) (189302400 . 15)
(189302400 . 15) (157766400 . 14)
(157766400 . 14) (126230400 . 13)
(126230400 . 13) (94694400 . 12)
(94694400 . 12) (78796800 . 11)
(78796800 . 11) (63072000 . 10)))
(63072000 . 10)))
(define (read-leap-second-table filename) ; (define (read-leap-second-table filename)
(set! tm:leap-second-table (tm:read-tai-utc-data filename)) ; (set! tm:leap-second-table (tm:read-tai-utc-data filename))
(values)) ; (values))
(define (tm:leap-second-delta utc-seconds) (define (tm:leap-second-delta utc-seconds)
@ -303,14 +302,9 @@
(define (tm:current-time-thread) (define (tm:current-time-thread)
(tm:time-error 'current-time 'unsupported-clock-type '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) (define (tm:current-time-process)
(let ((ticks/s (cpu-ticks/sec))) (tm:time-error 'current-time 'unsupported-clock-type 'time-gc))
(receive (userticks systicks childuserticks childsysticks) (process-times)
(make-time time-process
(* (remainder userticks ticks/s) (/ tm:nano ticks/s))
(quotient userticks ticks/s)))))
;; SCSH portability: GC time not available in scsh ;; SCSH portability: GC time not available in scsh
(define (tm:current-time-gc) (define (tm:current-time-gc)
@ -633,16 +627,17 @@
(else (else
(tm:char-pos char str (+ index 1) len)))) (tm:char-pos char str (+ index 1) len))))
(define (tm:split-real r) ;; return a string representing the decimal expansion of the fractional
(if (integer? r) ;; portion of a number, limited by a specified precision
(values r 0) (define (tm:decimal-expansion r precision)
(let ((str (number->string (exact->inexact r)))) (let loop ((num (- r (round r)))
(let ((ppos (tm:char-pos #\. str 0 (string-length str)))) (p precision))
(if ppos (if (or (= p 0) (= num 0))
(values ""
(string->number (substring str 0 ppos)) (let* ((num-times-10 (* 10 num))
(string->number (substring str (+ ppos 1) (string-length str)))) (round-num-times-10 (round num-times-10)))
(values r 0)))))) (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 ;; gives the seconds/date/month/year
(define (tm:decode-julian-day-number jdn) (define (tm:decode-julian-day-number jdn)
@ -668,7 +663,7 @@
;; SCSH portability: use scsh's DATE procedure ;; SCSH portability: use scsh's DATE procedure
(define (tm:local-tz-offset) (define (tm:local-tz-offset)
(date:tz-secs (date))) 0) ;; FIXME: quick hack
;; special thing -- ignores nanos ;; special thing -- ignores nanos
(define (tm:time->julian-day-number seconds tz-offset) (define (tm:time->julian-day-number seconds tz-offset)
@ -823,22 +818,21 @@
(define (date->julian-day date) (define (date->julian-day date)
(let ( (nanosecond (date-nanosecond date)) (let ( (nanosecond (date-nanosecond date))
(second (date-second date)) (second (date-second date))
(minute (date-minute date)) (minute (date-minute date))
(hour (date-hour date)) (hour (date-hour date))
(day (date-day date)) (day (date-day date))
(month (date-month date)) (month (date-month date))
(year (date-year date)) (year (date-year date))
(offset (date-zone-offset date)) ) (offset (date-zone-offset date)) )
(+ (tm:encode-julian-day-number day month year) (+ (tm:encode-julian-day-number day month year)
(- 1/2) (- 1/2)
;; SCSH portability: use binary / (+ (/ (+ (* hour 60 60)
(+ (/ (/ (+ (* hour 60 60) (* minute 60)
(* minute 60) second
second (/ nanosecond tm:nano)
(/ nanosecond tm:nano)) (- offset))
tm:sid) tm:sid)))))
(- offset))))))
(define (date->modified-julian-day date) (define (date->modified-julian-day date)
(- (date->julian-day date) (- (date->julian-day date)
@ -1047,17 +1041,11 @@
(display (tm:padding (date-second date) (display (tm:padding (date-second date)
pad-with 2) pad-with 2)
port)) port))
(receive (i f) (let* ((f (tm:decimal-expansion (/ (date-nanosecond date) tm:nano) 9)))
;;; SCSH portability: make use of / binary (if (> (string-length f) 0)
(tm:split-real (/ (begin
(date-nanosecond date) (display tm:locale-number-separator port)
(* tm:nano 1.0))) (display f port))))))
(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)))))))
(cons #\h (lambda (date pad-with port) (cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port))) (display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port) (cons #\H (lambda (date pad-with port)
@ -1487,4 +1475,3 @@
(if (tm:date-ok? newdate) (if (tm:date-ok? newdate)
newdate newdate
(tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string)))))