From 9ddcd1534e2363b9a9c893c1bc9664753cf3e724 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Sat, 7 Apr 2018 22:25:06 +0200 Subject: time --- modules/language/python/module/time.scm | 304 ++++++++++++++++++++++++++++++++ 1 file changed, 304 insertions(+) create mode 100644 modules/language/python/module/time.scm diff --git a/modules/language/python/module/time.scm b/modules/language/python/module/time.scm new file mode 100644 index 0000000..fc43906 --- /dev/null +++ b/modules/language/python/module/time.scm @@ -0,0 +1,304 @@ +(define-module (language python module time) + #:use-module (srfi srfi-19) + #:use-module (language python string) + #:use-module (language python try) + #:use-module (language python exceptions) + #:use-module (language python list) + #:use-module (language python def) + #:use-module (language python module errno) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (oop pf-objects) + + #:export (asctime clock + CLOCK_REALTIME CLOCK_MONOTONIC CLOCK_PROCESS CLOCK_THREAD + CLOCK_MONOTONIC CLOCK_REALTIME CLOCK_MONOTONIC + CLOCK_BOOTTIME CLOCK_REALTIME CLOCK_BOOTTIME CLOCK_TAI + clock_getres clock_gettime clock_settime time ctime + get_clock_info gmtime localtime mktime monotonic + pref_counter process_time sleep strftime strptime tzset + timezone altzone daylight tzname)) + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + +(define-syntax-rule (ca code) + (catch #t + (lambda () code) + (lambda x (raise error x)))) + +(define-syntax-rule (rm code) + (let ((r (ca code))) + (if (< r 0) + (raise error (errno) ((@ (guile) strerror) (errno))) + r))) + +(define (scmdate t) + (cond + ((number? t) + ((@ (guile) local-time) (inexact->exact (floor (* t 1.0))))) + ((struct? t) + ((ref t 'guile))) + (else t))) + +(define-python-class namespace () + (define __init__ + (lam (self (** kw)) + (set self '_kw kw))) + + (define __getitem__ + (lambda (self x) + (pylist-ref (ref self '_kw) x))) + + (define __repr__ + (lambda (self) + (format #f "~a" (ref self '_kw))))) + + +(define-python-class struct_time () + (define* __init__ + (lambda (self x) + (cond + ((number? x) + (__init__ self ((@ (guile) localtime) + (inexact->exact (floor (* 1.0 x)))))) + ((vector? x) + (set self 'tm_year (+ 1900 (tm:year x))) + (set self 'tm_mon (+ 1 (tm:mon x))) + (set self 'tm_mday (tm:mday x)) + (set self 'tm_hour (tm:hour x)) + (set self 'tm_min (tm:min x)) + (set self 'tm_sec (tm:sec x)) + (set self 'tm_wday (tm:wday x)) + (set self 'tm_yday (+ 1 (tm:yday x))) + (set self 'tm_isdst (tm:isdst x)) + (set self 'tm_zone (tm:zone x)) + (set self 'tm_gmtoff (tm:gmtoff x))) + (else + (set self 'tm_year (ref x 'tm_year)) + (set self 'tm_mon (ref x 'tm_mon)) + (set self 'tm_mday (ref x 'tm_mday)) + (set self 'tm_hour (ref x 'tm_hour)) + (set self 'tm_min (ref x 'tm_min)) + (set self 'tm_sec (ref x 'tm_sec)) + (set self 'tm_wday (ref x 'tm_wday)) + (set self 'tm_yday (ref x 'tm_yday)) + (set self 'tm_isdst (ref x 'tm_isdst)) + (set self 'tm_zone (ref x 'tm_zone)) + (set self 'tm_gmtoff (ref x 'tm_gmtoff)))))) + + (define guile + (lambda (self) + (let ((res ((@ (guile) localtime) 0))) + (set-tm:year res (- (ref self 'tm_year) 1900)) + (set-tm:mon res (- (ref self 'tm_mon) 1)) + (set-tm:mday res (ref self 'tm_day)) + (set-tm:hour res (ref self 'tm_hour)) + (set-tm:min res (ref self 'tm_min)) + (set-tm:sec res (ref self 'tm_sec)) + (set-tm:wday res (ref self 'tm_wday)) + (set-tm:yday res (- (res self 'tm_yday) 1)) + (set-tm:isdst res (ref self 'tm_isdst)) + (set-tm:zone res (ref self 'tm_zone)) + (set-tm:gmtoff res (ref self 'tm_gmtoff)) + res))) + + (define __repr__ + (lambda (self) + (format #f "date(year ~a, mon ~a, day ~a, hour ~a, min ~a, sec ~a : ~a)" + (ref self 'tm_year) + (ref self 'tm_mon) + (ref self 'tm_mday) + (ref self 'tm_hour) + (ref self 'tm_min) + (ref self 'tm_sec) + (ref self 'tm_zone)))) + + (define __getitem__ + (lambda (self n) + (case n + ((0) (ref self 'tm_year)) + ((1) (ref self 'tm_month)) + ((2) (ref self 'tm_mday)) + ((3) (ref self 'tm_hour)) + ((4) (ref self 'tm_min)) + ((5) (ref self 'tm_sec)) + ((6) (ref self 'tm_wday)) + ((7) (ref self 'tm_yday)) + ((8) (ref self 'tm_isdst)) + (else + (raise KeyError "date index out of bound [0,8] got" n)))))) + +(define (date-scm x) (ref x '_date)) + +(define* (asctime #:optional (t None)) + (ca + (let ((t2 (let lp ((t t)) + (cond + ((eq? t None) + (current-date)) + ((number? t) + (lp (make-time time-utc 0 + (inexact->exact (floor (* t 1.0)))))) + ((time? t) + (time-utc->date t)) + + ((vector? t) + (lp ((@ (guile) mktime) t))) + + ((struct? t) + (lp (scmdate t))))))) + (date->string t2)))) + +(define (clock) + (let ((t (current-time time-process))) + (+ (time-second t) (/ (time-nanosecond t) 1000000000.0)))) + +(define CLOCK_REALTIME 0) +(define CLOCK_MONOTONIC 1) +(define CLOCK_PROCESS_CPUTIME_ID 2) +(define CLOCK_THREAD_CPUTIME_ID 3) +(define CLOCK_MONOTONIC_RAW 4) +(define CLOCK_REALTIME_COARSE 5) +(define CLOCK_MONOTONIC_COARSE 6) +(define CLOCK_BOOTTIME 7) +(define CLOCK_REALTIME_ALARM 8) +(define CLOCK_BOOTTIME_ALARM 9) +(define CLOCK_TAI 11) + +(define clock_getres + (let ((f (pointer->procedure int + (dynamic-func "clock_getres" (dynamic-link)) + (list int '*)))) + (lambda (clk_id) + (let* ((v (make-bytevector 16)) + (vp (bytevector->pointer v))) + (rm (f clk_id vp)) + (+ (bytevector-s64-ref v 0 (native-endianness)) + (/ (bytevector-s64-ref v 8 (native-endianness)) + 1e9)))))) + +(define clock_gettime + (let ((f (pointer->procedure int + (dynamic-func "clock_gettime" (dynamic-link)) + (list int '*)))) + (lambda (clk_id) + (let* ((v (make-bytevector 16)) + (vp (bytevector->pointer v))) + (rm (f clk_id vp)) + (+ (bytevector-s64-ref v 0 (native-endianness)) + (/ (bytevector-s64-ref v 8 (native-endianness)) + 1e9)))))) + +(define clock_settime + (let ((f (pointer->procedure int + (dynamic-func "clock_settime" (dynamic-link)) + (list int '*)))) + (lambda (clk_id time) + (let* ((v (make-bytevector 16)) + (vp (bytevector->pointer v)) + (a (inexact->exact (floor time))) + (b (modulo (inexact->exact (* (floor time) 1e9)) 1000000000))) + (bytevector-s64-set! v 0 a (native-endianness)) + (bytevector-s64-set! v 8 b (native-endianness)) + (rm (f clk_id vp)) + (values))))) + +(define (time) ((@ (guile) current-time))) + +(define* (ctime #:optional (sec None)) + (define sec2 (if (eq? sec None) (time) sec)) + (ca (date->string (time-utc->date sec2)))) + +(define (get_clock_info name2) + (define name (scm-str name2)) + (cond + ((equal? name "clock") + (namespace #:adjustable #t + #:implementation "clock()" + #:monotonic #f + #:resolution 1e-6)) + + ((equal? name "monotonic") + (namespace #:adjustable #f + #:implementation "clock_gettime(CLOCK_MONOTONIC)" + #:monotonic #t + #:resolution (clock_getres CLOCK_MONOTONIC))) + + ((equal? name "perf_counter") + (namespace #:adjustable #f + #:implementation "clock_gettime(CLOCK_MONOTONIC)" + #:monotonic #t + #:resolution (clock_getres CLOCK_MONOTONIC))) + + ((equal? name "process_time") + (namespace #:adjustable #f + #:implementation "clock_gettime(CLOCK_PROCESS_CPUTIME_ID)" + #:monotonic #t + #:resolution (clock_getres CLOCK_PROCESS_CPUTIME_ID))) + + ((equal? name "time") + (namespace #:adjustable #t + #:implementation "clock_gettime(CLOCK_REALTIME)" + #:monotonic #f + #:resolution (clock_getres CLOCK_REALTIME))))) + +(define* (gmtime #:optional (secs None)) + (define secs2 (inexact->exact + (floor (if (eq? secs None) (time) secs)))) + (ca (struct_time ((@ (guile) gmtime) secs2)))) + +(define* (localtime #:optional (secs None)) + (define secs2 (inexact->exact + (floor (if (eq? secs None) (time) secs)))) + (ca (struct_time ((@ (guile) localtime) secs2)))) + +(define (mktime t) + (ca (car (mktime (ref t 'guile-repr))))) + + +(define (monotonic) (clock_gettime CLOCK_MONOTONIC)) +(define (pref_counter) (clock_gettime CLOCK_MONOTONIC)) +(define (process_time) (clock_gettime CLOCK_PROCESS_CPUTIME_ID)) +(define (sleep secs) + (usleep (inexact->exact (floor (* secs 1e6))))) + +(define* (strftime format #:optional (t None)) + (define t2 (if (eq? t None) (localtime) t)) + (ca ((@ (guile) strftime) (scm-str format) (scmdate t2)))) + +(define* (strptime string #:optional (format None)) + (define format2 (if (eq? format None) + "%a %b %d %H:%M:%S %Y" + (scm-str format))) + (define string2 (scm-str string)) + (let ((res (ca ((@ (guile) strptime) format2 string2)))) + (if (= (cdr res) 0) + (struct_time (car res)) + (raise ValueError "charcter unparsed " (cdr res))))) + +(define tzset (@ (guile) tzset)) + +(define winter + (let* ((x ((@ (guile) current-time))) + (d ((@ (guile) localtime) x)) + (y (- x (* (tm:mday d) 3600 24)))) + y)) + +(define summer + (let* ((x ((@ (guile) current-time))) + (d ((@ (guile) localtime) x)) + (y (+ (- x (* (tm:mday d) 3600 24)) (* (/ 364 2) 3600 24)))) + y)) + +(define timezone (tm:gmtoff ((@ (guile) localtime) 0))) + +(define altzone + (let ((s (tm:gmtoff ((@ (guile) localtime) summer))) + (w (tm:gmtoff ((@ (guile) localtime) winter)))) + (if (= s timezone) w s))) + +(define daylight (tm:isdst ((@ (guile) localtime) summer))) + +(define tzname + (list (tm:zone ((@ (guile) localtime) winter)) + (tm:zone ((@ (guile) localtime) summer)))) -- cgit v1.2.3