working towards snow portability

lib/chibi/binary-record.sld

@@ -1,11 +1,21 @@
 
 (define-library (chibi binary-record)
   (import (scheme base)
-          (srfi 1) (srfi 9)
+          (srfi 1)
-          (chibi io) (chibi string)
+          (chibi string))
-          (only (chibi) identifier? er-macro-transformer))
   (cond-expand
    ((library (srfi 33)) (import (srfi 33)))
    (else (import (srfi 60))))
+  (cond-expand
+   (chibi
+    (import (only (chibi) identifier? er-macro-transformer)))
+   (chicken
+    (import chicken)
+    (begin
+      (define identifier? symbol?)))
+   (sagittarius
+    (import (sagittarius))
+    (begin
+      (define identifier? symbol?))))
   (export define-binary-record-type)
   (include "binary-record.scm"))

lib/chibi/filesystem.sld

@@ -35,6 +35,90 @@
           file-is-readable? file-is-writable? file-is-executable?
           lock/shared lock/exclusive lock/non-blocking lock/unlock
           chmod is-a-tty?)
-  (import (chibi) (chibi string))
+  (import (chibi string))
-  (include-shared "filesystem")
+  (cond-expand
+   (chibi
+    (import (chibi))
+    (include-shared "filesystem"))
+   (chicken
+    (import (scheme base) (library) (posix))
+    (begin
+      (define file-status file-stat)
+      (define (file-link-status x) (file-stat x #t))
+      (define (stat-dev x) (vector-ref x 9))
+      (define (stat-ino x) (vector-ref x 0))
+      (define (stat-mode x) (vector-ref x 1))
+      (define (stat-nlinks x) (vector-ref x 2))
+      (define (stat-uid x) (vector-ref x 3))
+      (define (stat-gid x) (vector-ref x 4))
+      (define (stat-rdev x) (vector-ref x 10))
+      (define (stat-size x) (vector-ref x 5))
+      (define (stat-blksize x) (vector-ref x 11))
+      (define (stat-blocks x) (vector-ref x 12))
+      (define (stat-atime x) (vector-ref x 6))
+      (define (stat-mtime x) (vector-ref x 7))
+      (define (stat-ctime x) (vector-ref x 8))
+      (define duplicate-file-descriptor duplicate-fileno)
+      (define duplicate-file-descriptor-to duplicate-fileno)
+      (define close-file-descriptor file-close)
+      (define open-input-file-descriptor open-input-file*)
+      (define open-output-file-descriptor open-output-file*)
+      (define link-file file-link)
+      (define symbolic-link-file create-symbolic-link)
+      (define read-link read-symbolic-link)
+      (define open file-open)
+      (define open-pipe create-pipe)
+      (define make-fifo create-fifo)
+      (define file-regular? regular-file?)
+      (define file-directory? directory?)
+      (define file-character? character-device?)
+      (define file-block? block-device?)
+      (define file-fifo? fifo?)
+      (define file-link? symbolic-link?)
+      (define file-socket? socket?)
+      (define file-is-readable? file-read-access?)
+      (define file-is-writable? file-write-access?)
+      (define file-is-executable? file-execute-access?)
+      (define (get-file-descriptor-flags fileno)
+        (file-control fileno fcntl/getfd))
+      (define (set-file-descriptor-flags! fileno x)
+        (file-control fileno fcntl/setfd x))
+      (define (get-file-descriptor-status fileno)
+        (file-control fileno fcntl/getfl))
+      (define (set-file-descriptor-status! fileno x)
+        (file-control fileno fcntl/setfl x))
+      (define open/read-write open/rdwr)
+      (define open/create open/creat)
+      (define open/exclusive open/excl)
+      (define open/truncate open/trunc)
+      (define open/non-block open/nonblock)
+      (define chmod change-file-mode)
+      (define is-a-tty? terminal-port?)
+      ))
+   (sagittarius
+    (import (scheme base) (sagittarius))
+    (begin
+      (define (file-status x) x)
+      (define file-link-status file-status)
+      (define-syntax define-unimplemented
+        (syntax-rules ()
+          ((define-unimplemented def ...)
+           (define (def . x) (error "unimplemented" 'def)) ...)))
+      (define-unimplemented
+        stat-dev stat-ino stat-mode stat-nlinks stat-uid stat-gid
+        stat-rdev stat-blksize stat-blocks)
+      (define (stat-size x) (file-size-in-bytes x))
+      (define (stat-atime x) (file-stat-atime x))
+      (define (stat-mtime x) (file-stat-mtime x))
+      (define (stat-ctime x) (file-stat-ctime x))
+      (define file-is-readable? file-readable?)
+      (define file-is-writable? file-writable?)
+      (define file-is-executable? file-executable?)
+      (define file-link? file-symbolic-link?)
+
+      (define-unimplemented
+        duplicate-file-descriptor duplicate-file-descriptor-to
+        close-file-descriptor open-input-file-descriptor
+        open-output-file-descriptor)
+      )))
   (include "filesystem.scm"))

lib/chibi/snow/fort.sld

@@ -15,7 +15,6 @@
           (scheme file)
           (srfi 1)
           (srfi 18)
-          (srfi 33)
           (chibi snow package)
           (chibi bytevector)
           (chibi config)
@@ -29,6 +28,11 @@
           (chibi string)
           (chibi sxml)
           (chibi tar))
+  (cond-expand
+   ((library (srfi 33))
+    (import (srfi 33)))
+   (else
+    (import (srfi 60))))
   (cond-expand
    (chibi
     (import (only (chibi ast)

lib/chibi/snow/interface.sld

@@ -4,6 +4,54 @@
           restore-history save-history)
   (import (scheme base) (scheme char) (scheme read) (scheme write)
           (scheme file) (scheme process-context) (srfi 1)
-          (chibi config) (chibi filesystem) (chibi pathname)
+          (chibi config) (chibi pathname) (chibi show))
-          (chibi show) (chibi stty) (chibi term edit-line))
+  (cond-expand
+   (chibi
+    (import (chibi filesystem) (chibi stty)))
+   (chicken
+    (import posix stty)
+    (begin
+      (define (create-directory* dir) (create-directory dir #t))
+      (define (edit-line ))))
+   (sagittarius
+    (import (only (sagittarius) create-directory)
+            (chibi string))
+    (begin
+      (define (create-directory* dir . o)
+        (let ((mode (if (pair? o) (car o) #o755)))
+          (or (file-directory? dir)
+              (create-directory dir mode)
+              (let* ((start (string-cursor-start dir))
+                     (slash
+                      (string-find-right dir #\/ start
+                                         (string-skip-right dir #\/))))
+                (and (string-cursor>? slash start)
+                     (let ((parent (substring-cursor dir start slash)))
+                       (and (not (equal? parent dir))
+                            (not (file-exists? parent))
+                            (create-directory* parent mode)
+                            (create-directory dir mode))))))))
+      (define (with-stty spec thunk)
+        (thunk)))))
+  (cond-expand
+   (chibi
+    (import (chibi term edit-line)))
+   (else
+    (begin
+      (define (get-key ls key . o)
+        (let ((x (memq key ls)))
+          (if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
+      (define (edit-line . args)
+        (let ((in (if (and (pair? args) (input-port? (car args)))
+                      (car args)
+                      (current-input-port)))
+              (out (if (and (eq? in (car args))
+                            (pair? (cdr args))
+                            (output-port? (cadr args)))
+                       (cadr args)
+                       (current-output-port)))
+              (prompter (get-key args 'prompt: "> ")))
+          (display (if (procedure? prompter) (prompter) prompter) out)
+          (flush-output-port out)
+          (read-line in))))))
   (include "interface.scm"))

lib/chibi/snow/package.sld

@@ -34,7 +34,6 @@
           (chibi crypto md5)
           (chibi crypto rsa)
           (chibi crypto sha2)
-          (chibi filesystem)
           (chibi io)
           (chibi pathname)
           (chibi regexp)

lib/chibi/tar.sld

@@ -1,8 +1,14 @@
 
 (define-library (chibi tar)
-  (import (scheme base) (scheme file) (scheme time) (srfi 1) (srfi 33)
+  (import (scheme base) (scheme file) (scheme time) (srfi 1)
-          (chibi string) (chibi binary-record)
+          (chibi string) (chibi binary-record) (chibi pathname)
-          (chibi pathname) (chibi filesystem) (chibi system))
+          (chibi filesystem)
+          (chibi system))
+  (cond-expand
+   ((library (srfi 33))
+    (import (srfi 33)))
+   (else
+    (import (srfi 60))))
   (export
    ;; basic
    tar make-tar tar? read-tar write-tar