portability changes

lib/chibi/filesystem.scm

@@ -127,6 +127,9 @@
 (define (file-num-blocks x) (stat-blocks (if (stat? x) x (file-status x))))
 (define (file-access-time x) (stat-atime (if (stat? x) x (file-status x))))
 (define (file-modification-time x) (stat-mtime (if (stat? x) x (file-status x))))
+(define (file-modification-time/safe x)
+  (let ((status (if (stat? x) x (file-status x))))
+    (and status (stat-mtime status))))
 (define (file-change-time x) (stat-ctime (if (stat? x) x (file-status x))))
 
 ;;> File status accessors.  \var{x} should be a string indicating

lib/chibi/filesystem.sld

@@ -21,7 +21,8 @@
           file-owner                file-group
           file-represented-device   file-size
           file-block-size           file-num-blocks
-          file-access-time file-modification-time file-change-time
+          file-access-time file-change-time
+          file-modification-time  file-modification-time/safe
           file-regular?    file-directory?        file-character?
           file-block?      file-fifo?             file-link?
           file-socket?     file-exists?

lib/chibi/log.scm

@@ -158,9 +158,7 @@
   (if (pair? o)
       (logger-file-set! logger (car o)))
   (if (string? (logger-file logger))
-      (let ((fd (open (logger-file logger)
-                      (+ open/create open/write open/append open/non-block))))
-        (logger-port-set! logger (open-output-file-descriptor fd)))
+      (logger-port-set! logger (open-output-file/append (logger-file logger)))
       (logger-port-set! logger (current-error-port))))
 
 (define (log-close logger)

lib/chibi/log.sld

@@ -21,6 +21,23 @@
    ;; the default logger
    default-logger log-emergency log-alert log-critical log-error
    log-warn log-notice log-info log-debug)
-  (import (chibi) (srfi 9) (chibi time) (chibi process) (chibi system)
-          (chibi filesystem) (chibi string) (chibi show base))
+  (import (chibi time) (chibi string) (chibi show base))
+  (cond-expand
+   (chibi
+    (import (chibi) (chibi filesystem) (chibi process) (chibi system) (srfi 9))
+    (begin
+      (define (open-output-file/append path)
+        (let ((fd (open path
+                        (+ open/create open/write open/append open/non-block))))
+          (open-output-file-descriptor fd)))))
+   (else
+    (import (scheme base))
+    (begin
+      (define open-output-file/append open-output-file)
+      (define (file-lock port-or-fileno mode) 'unsupported)
+      (define lock/exclusive 'unsupported)
+      (define lock/unlock 'unsupported)
+      (define (current-process-id) -1)
+      (define (current-user-id) -1)
+      (define (current-group-id) -1))))
   (include "log.scm"))

lib/chibi/memoize-test.sld

@@ -1,26 +1,26 @@
 (define-library (chibi memoize-test)
   (export run-tests)
-  (import (chibi) (chibi memoize) (chibi filesystem) (chibi test))
+  (import (scheme base) (scheme file) (chibi memoize) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "memoize")
 
-      (define-memoized (fib n)
-        (if (<= n 1)
-            1
-            (+ (fib (- n 1)) (fib (- n 2)))))
+      (let ()
+        (define-memoized (fib n)
+          (if (<= n 1)
+              1
+              (+ (fib (- n 1)) (fib (- n 2)))))
+        (test 1 (fib 1))
+        (test 573147844013817084101 (fib 100)))
 
-      (test 1 (fib 1))
-      (test 573147844013817084101 (fib 100))
-
-      (define-memoized (ack m n)
-        (cond
-         ((= m 0) (+ n 1))
-         ((= n 0) (ack (- m 1) 1))
-         (else (ack (- m 1) (ack m (- n 1))))))
-
-      (test 29 (ack 3 2))
-      (test 61 (ack 3 3))
+      (let ()
+        (define-memoized (ack m n)
+          (cond
+           ((= m 0) (+ n 1))
+           ((= n 0) (ack (- m 1) 1))
+           (else (ack (- m 1) (ack m (- n 1))))))
+        (test 29 (ack 3 2))
+        (test 61 (ack 3 3)))
 
       (let ((n 0))
         (let ((f (memoize (lambda (x) (set! n (+ n 1)) (* x x)))))

lib/chibi/memoize.scm

@@ -120,7 +120,7 @@
 
 (define (memoize-file-loader proc . o)
   (let* ((f (lambda (file . rest)
-              (let ((mtime (file-modification-time file)))
+              (let ((mtime (file-modification-time/safe file)))
                 (cons mtime (apply proc file rest)))))
          (g (apply memoize f o))
          (reloader? (cond ((memq 'reloader?: o) => cdr) (else #f))))
@@ -129,8 +129,10 @@
         (let-syntax ((update!
                       (syntax-rules ()
                         ((update! default)
-                         (let ((mtime (file-modification-time file)))
-                           (if (> mtime (car cell))
+                         (let ((mtime (file-modification-time/safe file)))
+                           (if (and mtime
+                                    (or (not (car cell))
+                                        (> mtime (car cell))))
                                (let ((res (apply proc file rest)))
                                  (set-car! cell mtime)
                                  (set-cdr! cell res)
@@ -144,10 +146,11 @@
 ;; persistent memoization
 
 (define (get-memo-directory proc-name)
-  (let ((uid (current-user-id)))
-    (if (zero? uid)
-        (make-path "/var/run/memo.d" proc-name)
-        (make-path (user-home (user-information uid)) ".memo.d" proc-name))))
+  (or (get-environment-variable "MEMOIZE_DIR")
+      (if (i-am-root?)
+          (make-path "/var/run/memo.d" proc-name)
+          (make-path (or (get-environment-variable "HOME") ".")
+                     ".memo.d" proc-name))))
 
 (define (encode-file-name str)
   (define (file-name-safe-char? ch)
@@ -163,10 +166,11 @@
     (if (>= from to)
         res
         (cons (substring-cursor str from to) res)))
-  (let ((end (string-cursor-end str)))
-    (let lp ((from 0) (to 0) (res '()))
+  (let ((start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (let lp ((from start) (to start) (res '()))
       (if (string-cursor>=? to end)
-          (if (zero? from)
+          (if (string-cursor=? from start)
               str
               (string-concatenate (reverse (collect str from to res))))
           (let* ((ch (string-cursor-ref str to))
@@ -177,9 +181,9 @@
                                     (collect str from to res)))))))))
 
 (define (default-args-encoder args)
-  (encode-file-name
-   (string-append (call-with-output-string (lambda (out) (write/ss args out)))
-                  ".memo")))
+  (let ((out (open-output-string)))
+    (write/ss args out)
+    (encode-file-name (string-append (get-output-string out) ".memo"))))
 
 ;;> Returns a memoized version of the procedure \var{proc} which
 ;;> stores the memoized results persistently in a file.  Garbage
@@ -235,7 +239,7 @@
                     (init-size init-size: 31)
                     (compute-size compute-size: (lambda (k v) 1))
                     (size-limit size-limit: 1000))
-    (let ((tab (make-hash-table equal hash init-size)))
+    (let ((tab (make-hash-table equal hash))) ; init-size
       (%make-lru-cache tab '() '() 0 size-limit compute-size))))
 
 ;; add entry to the back of the queue

lib/chibi/memoize.sld

@@ -1,13 +1,18 @@
 
 (define-library (chibi memoize)
-  (import (chibi) (chibi optional) (chibi time) (chibi io)
-          (chibi pathname) (chibi filesystem) (chibi system)
-          (srfi 9) (srfi 38) (srfi 69))
+  (import (chibi optional) (chibi pathname) (chibi string)
+          (srfi 9) (srfi 38) (srfi 69) (srfi 98))
   (cond-expand
    (chibi
-    (import (chibi ast)))
-   (else
+    (import (chibi) (chibi ast) (chibi system) (chibi filesystem))
     (begin
+      (define (i-am-root?)
+        (zero? (current-user-id)))))
+   (else
+    (import (scheme base) (scheme char) (scheme file))
+    (begin
+      (define (i-am-root?)
+        (equal? "root" (get-environment-variable "USER")))
       (define (procedure-name x) #f)
       (define (procedure-arity x) #f)
       (define (procedure-variadic? x) #f))))

lib/chibi/time.sld

@@ -18,8 +18,31 @@
             resource-usage-max-rss resource-usage/self
             resource-usage/children get-resource-usage))
    (else))
-  (import (chibi))
-  (include-shared "time")
+  (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 date-year)
+      (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))
@@ -39,6 +62,8 @@
     (define-syntax time
       (syntax-rules ()
         ((time expr)
-         (time (call-with-output-string (lambda (out) (write 'expr out))) expr))
+         (let ((out (open-output-string)))
+           (write 'expr out)
+           (time (get-output-string out) expr)))
         ((time name expr)
          (time* name (lambda () expr)))))))