(let ()

(define $clock-gettime ; clock_id -> tspair

(foreign-procedure "(cs)clock_gettime"

(integer-32)

scheme-object))

(define $gmtime ; #f|tzoff X #f|tspair -> dtvec (returns #f on error)

(foreign-procedure "(cs)gmtime"

(scheme-object scheme-object)

scheme-object))

(define $asctime ; #f | dtvec -> string (returns #f on error)

(foreign-procedure "(cs)asctime"

(scheme-object)

scheme-object))

(define $mktime ; dtvec -> tspair (returns #f on error)

(foreign-procedure "(cs)mktime"

(scheme-object)

scheme-object))

(define-record-type ts

(fields (mutable typeno) (immutable pair))

(nongenerative #{ts a5dq4nztnmq6xlgp-a})

(sealed #t))

(define ts-type->typeno

(lambda (who type)

(case type

[(time-process) (constant time-process)]

[(time-thread) (constant time-thread)]

[(time-duration) (constant time-duration)]

[(time-monotonic) (constant time-monotonic)]

[(time-utc) (constant time-utc)]

[(time-collector-cpu) (constant time-collector-cpu)]

[(time-collector-real) (constant time-collector-real)]

[else ($oops who "unrecognized time type ~s" type)])))

(define ts-typeno->type

(lambda (typeno)

(cond

[(eq? typeno (constant time-process)) 'time-process]

[(eq? typeno (constant time-thread)) 'time-thread]

[(eq? typeno (constant time-duration)) 'time-duration]

[(eq? typeno (constant time-monotonic)) 'time-monotonic]

[(eq? typeno (constant time-utc)) 'time-utc]

[(eq? typeno (constant time-collector-cpu)) 'time-collector-cpu]

[(eq? typeno (constant time-collector-real)) 'time-collector-real]

[else ($oops 'time-internal "unexpected typeno ~s" typeno)])))

(define ts-sec (lambda (ts) (car (ts-pair ts))))

(define ts-nsec (lambda (ts) (cdr (ts-pair ts))))

(define set-ts-sec! (lambda (ts n) (set-car! (ts-pair ts) n)))

(define set-ts-nsec! (lambda (ts n) (set-cdr! (ts-pair ts) n)))

(define (check-ts who ts)

(unless (ts? ts)

($oops who "~s is not a time record" ts)))

(define (check-ts-sec who sec)

(unless (or (fixnum? sec) (bignum? sec))

($oops who "invalid number of seconds ~s" sec)))

(define (check-same-type who t1 t2)

(unless (fx= (ts-typeno t1) (ts-typeno t2))

($oops who "types of ~s and ~s differ" t1 t2)))

(define (check-type-duration who t)

(unless (fx= (ts-typeno t) (constant time-duration))

($oops who "~s does not have type time-duration" t)))

(define-record-type dt

(fields (immutable vec))

(nongenerative #{dt a5jhglnb7tr8ubed-a})

(sealed #t))

(define (check-dt who dt)

(unless (dt? dt)

($oops who "~s is not a date record" dt)))

(define (check-nsec who nsec)

(unless (and (or (fixnum? nsec) (bignum? nsec)) (<= 0 nsec 999999999))

($oops who "invalid nanosecond ~s" nsec)))

(define (check-sec who sec)

(unless (and (fixnum? sec) (fx<= 0 sec 61))

($oops who "invalid second ~s" sec)))

(define (check-min who min)

(unless (and (fixnum? min) (fx<= 0 min 59))

($oops who "invalid minute ~s" min)))

(define (check-hour who hour)

(unless (and (fixnum? hour) (fx<= 0 hour 23))

($oops who "invalid hour ~s" hour)))

(define (check-day who day)

(unless (and (fixnum? day) (fx<= 1 day 31))

($oops who "invalid day ~s" day)))

(define (check-mon who mon)

(unless (and (fixnum? mon) (fx<= 1 mon 12))

($oops who "invalid month ~s" mon)))

(define (check-year who year)

(unless (and (fixnum? year) (fx>= year 1901))

($oops who "invalid year ~s" year)))

(define (check-tz who tz)

(unless (and (fixnum? tz)

; being generous here...

(fx<= (* -24 60 60) tz (* 24 60 60)))

($oops who "invalid time-zone offset ~s" tz)))

(define $copy-time

(lambda (t)

(let ([p (ts-pair t)])

(make-ts (ts-typeno t) (cons (car p) (cdr p))))))

(record-writer (type-descriptor ts)

(lambda (x p wr)

(let ([type (ts-typeno->type (ts-typeno x))] [sec (ts-sec x)] [nsec (ts-nsec x)])

(if (and (< sec 0) (> nsec 0))

(fprintf p "#<~s -~d.~9,'0d>" type (- -1 sec) (- 1000000000 nsec))

(fprintf p "#<~s ~d.~9,'0d>" type sec nsec)))))

(record-writer (type-descriptor dt)

(lambda (x p wr)

(fprintf p "#<date~@[ ~a~]>"

($asctime (dt-vec x)))))

(set! make-time

(lambda (type nsec sec)

(let ([typeno (ts-type->typeno 'make-time type)])

(check-nsec 'make-time nsec)

(check-ts-sec 'make-time sec)

(make-ts typeno (cons sec nsec)))))

(set! time? (lambda (x) (ts? x)))

(set! time-type

(lambda (ts)

(check-ts 'time-type ts)

(ts-typeno->type (ts-typeno ts))))

(set! time-second

(lambda (ts)

(check-ts 'time-second ts)

(ts-sec ts)))

(set! time-nanosecond

(lambda (ts)

(check-ts 'time-nanosecond ts)

(ts-nsec ts)))

(set! set-time-type!

(lambda (ts type)

(check-ts 'set-time-type! ts)

(ts-typeno-set! ts (ts-type->typeno 'set-time-type! type))))

(set! set-time-second!

(lambda (ts sec)

(check-ts 'set-time-second! ts)

(check-ts-sec 'set-time-second! sec)

(set-ts-sec! ts sec)))

(set! set-time-nanosecond!

(lambda (ts nsec)

(check-ts 'set-time-nanosecond! ts)

(check-nsec 'set-time-nanosecond! nsec)

(set-ts-nsec! ts nsec)))

(set! time=?

(lambda (t1 t2)

(check-ts 'time=? t1)

(check-ts 'time=? t2)

(check-same-type 'time=? t1 t2)

(and (= (ts-sec t1) (ts-sec t2))

(= (ts-nsec t1) (ts-nsec t2)))))

(set! time<?

(lambda (t1 t2)

(check-ts 'time<? t1)

(check-ts 'time<? t2)

(check-same-type 'time<? t1 t2)

(or (< (ts-sec t1) (ts-sec t2))

(and (= (ts-sec t1) (ts-sec t2))

(< (ts-nsec t1) (ts-nsec t2))))))

(set! time<=?

(lambda (t1 t2)

(check-ts 'time<=? t1)

(check-ts 'time<=? t2)

(check-same-type 'time<=? t1 t2)

(or (< (ts-sec t1) (ts-sec t2))

(and (= (ts-sec t1) (ts-sec t2))

(<= (ts-nsec t1) (ts-nsec t2))))))

(set! time>=?

(lambda (t1 t2)

(check-ts 'time>=? t1)

(check-ts 'time>=? t2)

(check-same-type 'time>=? t1 t2)

(or (> (ts-sec t1) (ts-sec t2))

(and (= (ts-sec t1) (ts-sec t2))

(>= (ts-nsec t1) (ts-nsec t2))))))

(set! time>?

(lambda (t1 t2)

(check-ts 'time>? t1)

(check-ts 'time>? t2)

(check-same-type 'time>? t1 t2)

(or (> (ts-sec t1) (ts-sec t2))

(and (= (ts-sec t1) (ts-sec t2))

(> (ts-nsec t1) (ts-nsec t2))))))

(let ([f (lambda (t1 t2 who)

(check-ts who t1)

(check-ts who t2)

(check-same-type who t1 t2)

(let-values ([(sec nsec)

(let ([sec (- (ts-sec t1) (ts-sec t2))]

[nsec (- (ts-nsec t1) (ts-nsec t2))])

(if (< nsec 0) (values (- sec 1) (+ nsec 1000000000)) (values sec nsec)))])

(make-ts (constant time-duration) (cons sec nsec))))])

(set-who! time-difference (lambda (t1 t2) (f t1 t2 who)))

(set-who! time-difference! (lambda (t1 t2) (f t1 t2 who))))

(let ([f (lambda (t1 t2 who)

(check-ts who t1)

(check-ts who t2)

(check-type-duration who t2)

(let-values ([(sec nsec)

(let ([sec (- (ts-sec t1) (ts-sec t2))]

[nsec (- (ts-nsec t1) (ts-nsec t2))])

(if (< nsec 0) (values (- sec 1) (+ nsec 1000000000)) (values sec nsec)))])

(make-ts (ts-typeno t1) (cons sec nsec))))])

(set-who! subtract-duration (lambda (t1 t2) (f t1 t2 who)))

(set-who! subtract-duration! (lambda (t1 t2) (f t1 t2 who))))

(let ([f (lambda (t1 t2 who)

(check-ts who t1)

(check-ts who t2)

(check-type-duration who t2)

(let-values ([(sec nsec)

(let ([sec (+ (time-second t1) (time-second t2))]

[nsec (+ (time-nanosecond t1) (time-nanosecond t2))])

(if (>= nsec 1000000000) (values (+ sec 1) (- nsec 1000000000)) (values sec nsec)))])

(make-ts (ts-typeno t1) (cons sec nsec))))])

(set-who! add-duration (lambda (t1 t2) (f t1 t2 who)))

(set-who! add-duration! (lambda (t1 t2) (f t1 t2 who))))

(set-who! copy-time

(lambda (t)

(check-ts who t)

($copy-time t)))

(set-who! current-time

(case-lambda

[() (let ([typeno (constant time-utc)])

(make-ts typeno ($clock-gettime typeno)))]

[(type)

(case type

[(time-collector-cpu) ($copy-time ($gc-cpu-time))]

[(time-collector-real) ($copy-time ($gc-real-time))]

[else (let ([typeno (ts-type->typeno who type)])

(make-ts typeno ($clock-gettime typeno)))])]))

(set! current-date

(case-lambda

[()

(let ([dtvec ($gmtime #f #f)])

(unless dtvec ($oops 'current-date "failed"))

(make-dt dtvec))]

[(tz)

(check-tz 'current-date tz)

(let ([dtvec ($gmtime tz #f)])

(unless dtvec ($oops 'current-date "failed"))

(make-dt dtvec))]))

(set! date-and-time ; ptime|#f -> string

(case-lambda

[() (or ($asctime #f) ($oops 'date-and-time "failed"))]

[(dt)

(check-dt 'date-and-time dt)

(or ($asctime (dt-vec dt))

($oops 'date-and-time "failed for date record ~s" dt))]))

(set! make-date

(lambda (nsec sec min hour day mon year tz)

(check-nsec 'make-date nsec)

(check-sec 'make-date sec)

(check-min 'make-date min)

(check-hour 'make-date hour)

; need more accurate check for day based on year and month

(check-day 'make-date day)

(check-mon 'make-date mon)

(check-year 'make-date year)

(check-tz 'make-date tz)

; keep in sync with cmacros.ss declarations of dtvec-nsec, etc.

(let ([dtvec (vector nsec sec min hour day mon (- year 1900) 0 0 0 tz)])

(unless ($mktime dtvec) ; for effect on dtvec

($oops 'make-date "invalid combination of arguments"))

(unless (fx= (vector-ref dtvec (constant dtvec-mday)) day)

($oops 'make-date "invalid day ~s for month ~s and year ~s" day mon year))

(make-dt dtvec))))

(set! date? (lambda (x) (dt? x)))

(let ()

(define-syntax date-getter

(syntax-rules ()

[(_ name index)

(set! name

(lambda (dt)

(check-dt 'name dt)

(vector-ref (dt-vec dt) index)))]))

(date-getter date-nanosecond (constant dtvec-nsec))

(date-getter date-second (constant dtvec-sec))

(date-getter date-minute (constant dtvec-min))

(date-getter date-hour (constant dtvec-hour))

(date-getter date-day (constant dtvec-mday))

(date-getter date-month (constant dtvec-mon))

; date-year is below

(date-getter date-week-day (constant dtvec-wday))

(date-getter date-year-day (constant dtvec-yday))

(date-getter date-zone-offset (constant dtvec-tzoff)))

(set! date-year

(lambda (dt)

(check-dt 'date-year dt)

(+ (vector-ref (dt-vec dt) (constant dtvec-year)) 1900)))

#;(set! date-week-number

(lambda (dt dowsw)

(unless (or (eq? dossw 0) (eq? dossw 1))

($oops 'date-week-number "invalid week starting day" dossw))

???))

(set-who! time-utc->date

(case-lambda

[(t)

(unless (and (ts? t) (eq? (ts-typeno t) (constant time-utc)))

($oops who "~s is not a utc time record" t))

(let ([dtvec ($gmtime #f (ts-pair t))])

(unless dtvec ($oops who "failed"))

(make-dt dtvec))]

[(t tz)

(unless (and (ts? t) (eq? (ts-typeno t) (constant time-utc)))

($oops who "~s is not a utc time record" t))

(check-tz 'current-date tz)

(let ([dtvec ($gmtime tz (ts-pair t))])

(unless dtvec ($oops who "failed"))

(make-dt dtvec))]))

(set-who! date->time-utc

(lambda (dt)

(check-dt who dt)

(let ([p ($mktime (dt-vec dt))])

(unless p ($oops who "conversion failed for ~s" dt))

(make-ts (constant time-utc) p))))