Commits

David Krentzlin committed 9c29ff7

applied patch to make copy-port work on 4.5.0. Thanks to mario goulart

  • Participants
  • Parent commits 55421e7

Comments (0)

Files changed (5)

backward-compatibility.scm

Empty file added.

backward-compatibility/copy-port.scm

+(define-constant +buf-size+ 1024)
+
+(define copy-port
+  (let ((read-char read-char)
+        (write-char write-char))
+    (define (read-buf port writer)
+      (let ((buf (make-string +buf-size+)))
+        (let loop ()
+          (let ((n (read-string! +buf-size+ buf port)))
+            (unless (eq? n 0)
+              (writer buf n)
+              (loop))))))
+    (define (write-buf buf n port writer)
+      (do ((i 0 (fx+ i 1)))
+          ((fx>= i n))
+        (writer (integer->char (##sys#byte buf i)) port)))
+    (define (read-and-write reader writer)
+      (let loop ()
+        (let ((x (reader)))
+          (unless (eof-object? x)
+            (writer x)
+            (loop)))))
+    (define (read-and-write-buf src dest reader)
+      (let ((buf (make-string +buf-size+)))
+        (let loop ((n 0))
+          (when (fx>= n +buf-size+)
+            (write-string buf +buf-size+ dest)
+            (set! n 0))
+          (let ((c (reader src)))
+            (cond ((eof-object? c)
+                   (when (fx>= n 0)
+                     (write-string buf n dest)))
+                  (else
+                   (##sys#setbyte buf n (char->integer c))
+                   (loop (fx+ n 1))))))))
+    (lambda (src dest #!optional (read read-char) (write write-char))
+      ;; does not check port args intentionally
+      (cond ((eq? read read-char)
+             (read-buf
+              src
+              (if (eq? write write-char)
+                  (lambda (buf n) (write-string buf n dest))
+                  (lambda (buf n) (write-buf buf n dest write)))))
+            ((eq? write write-char)
+             (read-and-write-buf src dest read))
+            (else
+             (read-and-write
+              (lambda () (read src))
+             (lambda (x) (write x dest))))))))

old-chickens-compat.scm

Empty file added.
 (require-library posix lolevel srfi-4)
 (import extras posix srfi-4 foreign lolevel ports)
 
+(include "backward-compatibility.scm")
 
 (define (kilobytes num)  (* num 1024))
 (define (megabytes num)  (* (kilobytes num) 1024))
            (try-compile sendfile-sun-test compile-only: #t))
           (else #f)))
 
+;; Compatibility with older chickens
+(if (string< (chicken-version) "4.6")
+    (copy-file (make-pathname "backward-compatibility" "copy-port.scm")
+               (make-pathname (current-directory) "backward-compatibility.scm"))
+    (with-output-to-file "backward-compatibility.scm" (cut display "")))
 
 (let ((features '()))
   (when madvise?