mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
72 lines
2.6 KiB
Scheme
72 lines
2.6 KiB
Scheme
|
|
(define-library (chibi time)
|
|
(export current-seconds get-time-of-day time
|
|
seconds->time seconds->string time->seconds time->string
|
|
make-timeval make-tm timeval-seconds timeval-microseconds
|
|
timezone-offset timezone-dst-time
|
|
time-second time-minute time-hour time-day time-month time-year
|
|
time-day-of-week time-day-of-year time-dst?
|
|
tm? timeval? timezone?)
|
|
(cond-expand
|
|
(solaris)
|
|
(else
|
|
(export time-offset time-timezone-name)))
|
|
(cond-expand
|
|
(emscripten)
|
|
(else
|
|
(export set-time-of-day!)))
|
|
(cond-expand
|
|
((or bsd linux)
|
|
(export rusage? resource-usage-time resource-usage-system-time
|
|
resource-usage-max-rss resource-usage/self
|
|
resource-usage/children get-resource-usage))
|
|
(else))
|
|
(cond-expand
|
|
(chibi
|
|
(import (chibi))
|
|
(include-shared "time"))
|
|
(else
|
|
(import (scheme base) (scheme write) (scheme time)
|
|
(rename (srfi 19) (time-second srfi-19:time-second)))
|
|
(begin
|
|
;; a SRFI-19 `date' is a datetime, which in C is a tm (time) struct
|
|
(define tm? date?)
|
|
(define time-second date-second)
|
|
(define time-minute date-minute)
|
|
(define time-hour date-hour)
|
|
(define time-day date-day)
|
|
(define time-month date-month)
|
|
(define (time-year x) (- (date-year x) 1900))
|
|
(define time-day-of-week date-week-day)
|
|
(define time-day-of-year date-year-day)
|
|
(define (seconds->time seconds)
|
|
(time-tai->date (make-time time-tai 0 (exact (round seconds)))))
|
|
(define current-seconds current-second)
|
|
(define (get-time-of-day)
|
|
(list (current-time) time-utc))
|
|
(define (timeval-seconds tv) (srfi-19:time-second tv))
|
|
(define (timeval-microseconds tv) (/ (time-nanosecond tv) 1000)))))
|
|
(begin
|
|
(define (timeval->milliseconds tv)
|
|
(quotient (+ (* 1000000 (timeval-seconds tv))
|
|
(timeval-microseconds tv))
|
|
1000))
|
|
(define (time* name thunk)
|
|
(let* ((start (car (get-time-of-day)))
|
|
(result (thunk))
|
|
(end (car (get-time-of-day)))
|
|
(msecs (- (timeval->milliseconds end)
|
|
(timeval->milliseconds start))))
|
|
(display name (current-error-port))
|
|
(display ": " (current-error-port))
|
|
(display msecs (current-error-port))
|
|
(display " ms\n" (current-error-port))
|
|
result))
|
|
(define-syntax time
|
|
(syntax-rules ()
|
|
((time expr)
|
|
(let ((out (open-output-string)))
|
|
(write 'expr out)
|
|
(time (get-output-string out) expr)))
|
|
((time name expr)
|
|
(time* name (lambda () expr)))))))
|