;;;; srfi-19-time.scm -*- Scheme -*- ;;;; Chicken port, Kon Lovett, Dec '05 ;; SRFI-19: Time Data Types and Procedures. ;; ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved. ;; ;; This document and translations of it may be copied and furnished to others, ;; and derivative works that comment on or otherwise explain it or assist in its ;; implementation may be prepared, copied, published and distributed, in whole or ;; in part, without restriction of any kind, provided that the above copyright ;; notice and this paragraph are included on all such copies and derivative works. ;; However, this document itself may not be modified in any way, such as by ;; removing the copyright notice or references to the Scheme Request For ;; Implementation process or editors, except as needed for the purpose of ;; developing SRFIs in which case the procedures for copyrights defined in the SRFI ;; process must be followed, or as required to translate it into languages other ;; than English. ;; ;; The limited permissions granted above are perpetual and will not be revoked ;; by the authors or their successors or assigns. ;; ;; This document and the information contained herein is provided on an "AS IS" ;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. (module srfi-19-time (;export ;;SRFI-19 time-tai time-utc time-monotonic time-thread time-process time-duration time-gc current-time time-resolution make-time time-type time-nanosecond time-second set-time-type! set-time-nanosecond! set-time-second! copy-time time<=? time=? time>? time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration! time-monotonic->time-tai time-monotonic->time-tai! time-monotonic->time-utc time-monotonic->time-utc! time-tai->time-monotonic time-tai->time-monotonic! time-tai->time-utc time-tai->time-utc! time-utc->time-monotonic time-utc->time-monotonic! time-utc->time-tai time-utc->time-tai! ;;Extensions time-record-printer-format one-second-duration one-nanosecond-duration zero-time make-duration divide-duration divide-duration! multiply-duration multiply-duration! time->srfi-18-time srfi-18-time->time time-max time-min time-negative? time-positive? time-zero? time-abs time-abs! time-negate time-negate! seconds->time nanoseconds->time nanoseconds->seconds milliseconds->time milliseconds->seconds time->nanoseconds time->milliseconds time->seconds time-compare) (import scheme) (import (chicken base)) (import (prefix (only srfi-18 seconds->time time->seconds) srfi-18:)) #;(import srfi-8) (import miscmacros) (import type-checks) (import type-errors) (import srfi-19-tm) (import srfi-19-support) ;;; ;; Time Type Constants (not used internally) (define time-duration 'duration) (define time-gc 'gc) (define time-monotonic 'monotonic) (define time-process 'process) (define time-tai 'tai) (define time-thread 'thread) (define time-utc 'utc) ;; Time CTORs (define (one-second-duration) (tm:make-time 'duration 0 1)) (define (one-nanosecond-duration) (tm:make-time 'duration 1 0)) (define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0)) (define (make-time tt ns sec) (check-time-elements 'make-time tt ns sec) (tm:make-time tt ns sec) ) (define (make-duration #!key (days 0) (hours 0) (minutes 0) (seconds 0) (milliseconds 0) (microseconds 0) (nanoseconds 0)) (let-values ( ((ns sec) (tm:duration-elements->time-values (check-real 'make-duration days 'days) (check-real 'make-duration hours 'hours) (check-real 'make-duration minutes 'minutes) (check-real 'make-duration seconds 'seconds) (check-real 'make-duration milliseconds 'milliseconds) (check-real 'make-duration microseconds 'microseconds) (check-real 'make-duration nanoseconds 'nanoseconds))) ) (check-time-elements 'make-duration 'duration ns sec) (tm:make-time 'duration ns sec) ) ) (define (copy-time tim) (tm:copy-time (check-time 'copy-time tim)) ) ;; Time record-type operations (define (time-type tim) (tm:time-type (check-time 'time-type tim)) ) (define (time-nanosecond tim) (tm:time-nanosecond (check-time 'time-nanosecond tim)) ) (define (time-second tim) (tm:time-second (check-time 'time-second tim)) ) (define (set-time-type! tim tt) (tm:time-type-set! (check-time 'set-time-type! tim) (check-time-type 'set-time-type! tt)) ) (define (set-time-nanosecond! tim ns) (tm:time-nanosecond-set! (check-time 'set-time-nanosecond! tim) (check-time-nanoseconds 'set-time-nanosecond! ns)) ) (define (set-time-second! tim sec) (tm:time-second-set! (check-time 'set-time-second! tim) (check-time-seconds 'set-time-second! sec)) ) ;; Seconds Conversion (define (nanoseconds->time ns . args) (let-optionals args ((tt 'duration)) (let-values ( ((ns sec) (tm:nanoseconds->time-values ns)) ) (check-time-elements 'nanoseconds->time tt ns sec) (tm:make-time tt ns sec) ) ) ) (define (nanoseconds->seconds ns) (tm:nanoseconds->seconds (check-real 'nanoseconds->seconds ns)) ) (define (milliseconds->time ms . args) (let-optionals args ((tt 'duration)) (let-values ( ((ns sec) (tm:milliseconds->time-values (check-raw-milliseconds 'milliseconds->time ms))) ) (check-time-elements 'milliseconds->time tt ns sec) (tm:make-time tt ns sec) ) ) ) (define (milliseconds->seconds ms) (tm:milliseconds->seconds (check-raw-milliseconds 'milliseconds->seconds ms)) ) ;; Converts a seconds value, may be fractional, into a time type. ;; The type of time default is time-duration. (define (seconds->time sec . args) (let-optionals args ((tt 'duration)) (tm:seconds->time (check-raw-seconds 'seconds->time sec) (check-time-type 'seconds->time tt)) ) ) (define (time->nanoseconds tim) (tm:time->nanoseconds (check-time 'time->nanoseconds tim)) ) (define (time->milliseconds tim) (tm:time->milliseconds (check-time 'time->milliseconds tim)) ) (define (time->seconds tim) (tm:time->seconds (check-time 'time->seconds tim)) ) ;; Current time routines (define (current-time . args) (let-optionals args ((tt 'utc)) (case tt ((monotonic) (tm:current-time-monotonic)) ((utc) (tm:current-time-utc)) ((tai) (tm:current-time-tai)) ((gc) (tm:current-time-gc)) ((process) (tm:current-time-process)) ((thread) (tm:current-time-thread)) (else (error-time-type 'current-time tt)) ) ) ) ;; -- Time Resolution ;; This is the resolution of the clock in nanoseconds. ;; This will be implementation specific. (define (time-resolution . args) (let-optionals args ((tt 'utc)) (tm:time-resolution (check-time-type 'time-resolution tt)) ) ) ;; SRFI-18 Routines (define (srfi-18-time->time srfi-18-tim) (tm:seconds->time (srfi-18:time->seconds srfi-18-tim) 'duration) ) (define (time->srfi-18-time tim) (srfi-18:seconds->time (exact->inexact (tm:time->seconds (check-time 'time->srfi-18-time tim)))) ) ;; Time Comparison (define (time-compare tim1 tim2) (check-time-compare 'time-compare tim1 tim2) (let ((dif (tm:time-compare tim1 tim2))) (cond ((negative? dif) -1) ((positive? dif) 1) (else 0) ) ) ) (define (time=? tim1 tim2) (check-time-compare 'time=? tim1 tim2) (tm:time=? tim1 tim2) ) (define (time>? tim1 tim2) (check-time-compare 'time>? tim1 tim2) (tm:time>? tim1 tim2) ) (define (time=? tim1 tim2) (check-time-compare 'time>=? tim1 tim2) (tm:time>=? tim1 tim2) ) (define (time<=? tim1 tim2) (check-time-compare 'time<=? tim1 tim2) (tm:time<=? tim1 tim2) ) (define (time-max tim1 . rest) (let ((tt (tm:time-type (check-time 'time-max tim1)))) (let loop ((acc tim1) (ls rest)) (if (null? ls) acc (let ((tim (car ls))) (check-time-and-type 'time-max tim tt) (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) ) (define (time-min tim1 . rest) (let ((tt (tm:time-type (check-time 'time-min tim1)))) (let loop ((acc tim1) (ls rest)) (if (null? ls) acc (let ((tim (car ls))) (check-time-and-type 'time-min tim tt) (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) ) ;; Time Arithmetic (define (time-difference tim1 tim2) (check-time-compare 'time-difference tim1 tim2) (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) (define (add-duration tim dur) (check-time-aritmetic 'add-duration tim dur) (tm:add-duration tim dur (tm:as-some-time tim)) ) (define (subtract-duration tim dur) (check-time-aritmetic 'subtract-duration tim dur) (tm:subtract-duration tim dur (tm:as-some-time tim)) ) (define (divide-duration dur num) (check-duration 'divide-duration dur) (tm:divide-duration dur num (tm:some-time 'duration)) ) (define (multiply-duration dur num) (check-duration 'multiply-duration dur) (tm:multiply-duration dur num (tm:some-time 'duration)) ) (define (time-abs tim) (check-time 'time-abs tim) (tm:time-abs tim (tm:as-some-time tim)) ) (define (time-negate tim) (check-time 'time-negate tim) (tm:time-negate tim (tm:as-some-time tim)) ) ;; (define (time-difference! tim1 tim2) (check-time-compare 'time-difference! tim1 tim2) (tm:time-difference tim1 tim2 tim1) ) (define (add-duration! tim dur) (check-time-aritmetic 'add-duration! tim dur) (tm:add-duration tim dur tim) ) (define (subtract-duration! tim dur) (check-time-aritmetic 'subtract-duration! tim dur) (tm:subtract-duration tim dur tim) ) (define (divide-duration! dur num) (check-duration 'divide-duration! dur) (tm:divide-duration dur num dur) ) (define (multiply-duration! dur num) (check-duration 'multiply-duration! dur) (tm:multiply-duration dur num dur) ) (define (time-abs! tim) (check-time 'time-abs! tim) (tm:time-abs tim tim) ) (define (time-negate! tim) (check-time 'time-negate! tim) (tm:time-negate tim tim) ) ;; (define (time-negative? tim) ;nanoseconds irrelevant (negative? (tm:time-second (check-time 'time-negative? tim))) ) (define (time-positive? tim) ;nanoseconds irrelevant (positive? (tm:time-second (check-time 'time-positive? tim))) ) (define (time-zero? tim) (check-time 'time-zero? tim) (and (zero? (tm:time-nanosecond tim)) (zero? (tm:time-second tim))) ) ;; Time Type Conversion ;; (define (time-tai->time-utc tim) (check-time-and-type 'time-tai->time-utc tim 'tai) (tm:time-tai->time-utc tim (tm:any-time)) ) (define (time-tai->time-monotonic tim) (check-time-and-type 'time-tai->time-monotonic tim 'tai) (tm:time-tai->time-monotonic tim (tm:any-time)) ) (define (time-utc->time-tai tim) (check-time-and-type 'time-utc->time-tai tim 'utc) (tm:time-utc->time-tai tim (tm:any-time)) ) (define (time-utc->time-monotonic tim) (check-time-and-type 'time-utc->time-monotonic tim 'utc) (tm:time-utc->time-monotonic tim (tm:any-time)) ) (define (time-monotonic->time-utc tim) (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic) (let ((ntim (tm:copy-time tim))) (tm:time-monotonic->time-utc ntim ntim) ) ) (define (time-monotonic->time-tai tim) (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic) (tm:time-monotonic->time-tai tim (tm:any-time)) ) ;; (define (time-tai->time-utc! tim) (check-time-and-type 'time-tai->time-utc! tim 'tai) (tm:time-tai->time-utc tim tim) ) (define (time-tai->time-monotonic! tim) (check-time-and-type 'time-tai->time-monotonic! tim 'tai) (tm:time-tai->time-monotonic tim tim) ) (define (time-utc->time-tai! tim) (check-time-and-type 'time-utc->time-tai! tim 'utc) (tm:time-utc->time-tai tim tim) ) (define (time-utc->time-monotonic! tim) (check-time-and-type 'time-utc->time-monotonic! tim 'utc) (tm:time-utc->time-monotonic tim tim) ) (define (time-monotonic->time-utc! tim) (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic) (tm:time-monotonic->time-utc tim tim) ) (define (time-monotonic->time-tai! tim) (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic) (tm:time-monotonic->time-tai tim tim) ) ;; (import (only (chicken read-syntax) define-reader-ctor)) (import (only (chicken format) format)) (define-constant TIME-FORMAT-SRFI-10 "#,(srfi-19-time ~A ~A ~A)") (define-constant TIME-FORMAT-BRACKET "#") (define time-record-printer-format (make-parameter 'SRFI-10 (lambda (x) (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x)) x (begin (warning 'time-record-printer-format "invalid format" x) (time-record-printer-format) ) ) ) ) ) (define (time-record-printer-format-string) (case (time-record-printer-format) ((srfi-10 SRFI-10) TIME-FORMAT-SRFI-10 ) (else TIME-FORMAT-BRACKET ) ) ) (define-record-printer (srfi-19-time tim out) (format out (time-record-printer-format-string) (tm:time-type tim) (tm:time-nanosecond tim) (tm:time-second tim)) ) ;SRFI-10 (define-reader-ctor 'srfi-19-time (lambda (tt ns sec) (tm:make-time tt ns sec))) ) ;module srfi-19-time