time

1 files changed, 304 insertions, 0 deletions

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))))