mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
78 lines
3.2 KiB
Scheme
78 lines
3.2 KiB
Scheme
;; time.sld - (scheme time) library definition
|
|
;;
|
|
;; Copyright (c) 2012 Alex Shinn. All rights reserved.
|
|
;; Copyright (c) 2012 Alan Watson. All rights reserved.
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
|
|
|
(define-library (scheme time)
|
|
(export current-second current-jiffy jiffies-per-second)
|
|
(import (chibi))
|
|
(import (scheme process-context))
|
|
(import (scheme time tai))
|
|
(include-shared "time")
|
|
;; If the environment variable SEXP_CLOCK_TYPE is set, its value
|
|
;; is used for the system clock type. If the environment variable
|
|
;; SEXP_CLOCK_TYPE is not set, then the system clock is ntp-like
|
|
;; if current-ntp-clock-values is a procedure and is posix-like
|
|
;; otherwise.
|
|
(cond-expand
|
|
(ntp
|
|
(begin
|
|
(define clock-type
|
|
(cond
|
|
((get-environment-variable "SEXP_CLOCK_TYPE")
|
|
=> (lambda (x)
|
|
(let ((type (string->symbol x)))
|
|
(case type
|
|
((posix-like tai-like ntp-like) type)
|
|
(else
|
|
(display "invalid value for SEXP_CLOCK_TYPE: " (current-error-port))
|
|
(write x (current-error-port))
|
|
(display " - expected \"ntp-like\", \"posix-like\" or \"tai-like\"\n" (current-error-port))
|
|
'ntp-like)))))
|
|
(else 'ntp-like)))))
|
|
(else
|
|
(begin (define clock-type 'posix-like))))
|
|
(begin
|
|
;; The value of the environment variable SEXP_CLOCK_EPOCH_OFFSET
|
|
;; specifies the offset of the system clock relative to the
|
|
;; standard epoch (1970-01-01 00:00:00 UTC for posix-like and
|
|
;; ntp-like clocks and 1970-01-01 00:00:00 TAI for tai-like system
|
|
;; clocks). If it not set, the offset is assumed to be zero. In
|
|
;; call-with-current-clock-values, the offset is added to the
|
|
;; current seconds before calling the procedure argument.
|
|
(define epoch-offset
|
|
(exact->inexact
|
|
(string->number
|
|
(or (get-environment-variable "SEXP_CLOCK_EPOCH_OFFSET")
|
|
"0"))))
|
|
|
|
;; Normally, one does not need to specify either the clock type or
|
|
;; clock epoch explicitly. One case where it might be necessary is
|
|
;; if the system clock runs on the TAI-10 timescale. In this case,
|
|
;; one should set SEXP_CLOCK_TYPE to "tai-like" and
|
|
;; SEXP_CLOCK_EPOCH_OFFSET to -10.
|
|
;;
|
|
;; The call-with-current-clock-values obtains the clock values
|
|
;; from the current-ntp-clock-values procedure, if the system
|
|
;; clock is ntp-like, and from the current-clock-second procedure
|
|
;; otherwise.
|
|
(define call-with-current-clock-values
|
|
(cond-expand
|
|
(ntp
|
|
(case clock-type
|
|
((ntp-like)
|
|
(lambda (p)
|
|
(let ((values-pair (current-ntp-clock-values)))
|
|
(p (+ (car values-pair) epoch-offset) (cdr values-pair)))))
|
|
(else
|
|
(lambda (p) (p (+ (current-clock-second) epoch-offset) #f)))))
|
|
(else
|
|
(lambda (p) (p (+ (current-clock-second) epoch-offset) #f)))))
|
|
|
|
;; Exported interface.
|
|
(define current-second
|
|
(make-tai-clock clock-type call-with-current-clock-values))
|
|
(define (current-jiffy)
|
|
(inexact->exact (round (* (current-second) (jiffies-per-second)))))
|
|
(define (jiffies-per-second) 1000)))
|