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!))
srfi-6
srfi-8
signals
srfi-9)
srfi-9
srfi-23)
(files (srfi srfi-19))))
; SRFI-20 - withdrawn

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

@ -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)))))