fix call-with-port procedures

`call-with-port` in R7RS, `call-with-input-file`, and `call-with-output-file` in R5RS
should catch exceptions and not close the port when the procuder didn't return.

CHANGELOG.md

@@ -8,6 +8,7 @@
 * fix exception when handling parse error for lonely `)` [#417](https://github.com/jcubic/lips/issues/417)
 * fix unboxing arguments of LIPS created classes [#411](https://github.com/jcubic/lips/issues/411)
 * fix space in front of output in REPL [#406](https://github.com/jcubic/lips/issues/406)
+* fix `call-with-port` in R7RS, `call-with-input-file`, and `call-with-output-file` in R5RS to catch errors and don't close the port
 
 ## 1.0.0-beta.20
 ### Feature

lib/R5RS.scm

@@ -1403,10 +1403,14 @@
    Procedure open file for reading, call user defined procedure with given port
    and then close the port. It return value that was returned by user proc
    and it close the port even if user proc throw exception."
-  (let ((p (open-input-file filename)))
+  (let ((p (open-input-file filename))
+        (throw #f))
     (try (proc p)
+         (catch (e)
+                (set! throw #t))
          (finally
-          (close-input-port p)))))
+          (if (not throw)
+              (close-input-port p))))))
 
 ;; -----------------------------------------------------------------------------
 (define (call-with-output-file filename proc)
@@ -1415,10 +1419,13 @@
    Procedure open file for writing, call user defined procedure with port
    and then close the port. It return value that was returned by user proc
    and it close the port even if user proc throw exception."
-  (let ((p (open-output-file filename)))
+  (let ((p (open-output-file filename)) (throw #f))
     (try (proc p)
+         (catch (e)
+                (set! throw #t))
          (finally
-          (close-output-port p)))))
+          (if (not throw)
+              (close-output-port p))))))
 
 ;; -----------------------------------------------------------------------------
 (define (with-input-from-port port thunk)

lib/R7RS.scm

@@ -1270,11 +1270,34 @@
   "(call-with-port port proc)
 
    Proc is executed with given port and after it returns, the port is closed."
-  (try
-   (proc port)
-   (finally
-    (if (procedure? port.close)
-        (port.close)))))
+  (let ((throw #f))
+    (try
+     (proc port)
+     (catch (e)
+            (set! throw #t))
+     (finally
+      (if (and (procedure? port.close) (not throw))
+          (port.close))))))
+
+;; -----------------------------------------------------------------------------
+(define (call-with-input-file filename proc)
+  "(call-with-input-file filename proc)
+
+   Procedure open file for reading, call user defined procedure with given port
+   and then close the port. It return value that was returned by user proc
+   and it close the port even if user proc throw exception."
+  (let ((p (open-input-file filename)))
+    (call-with-port p proc)))
+
+;; -----------------------------------------------------------------------------
+(define (call-with-output-file filename proc)
+  "(call-with-output-file filename proc)
+
+   Procedure open file for writing, call user defined procedure with port
+   and then close the port. It return value that was returned by user proc
+   and it close the port even if user proc throw exception."
+  (let ((p (open-output-file filename)))
+    (call-with-port p proc)))
 
 ;; -----------------------------------------------------------------------------
 (define (close-port port)

tests/ports.scm

@@ -316,3 +316,19 @@
                             (loop (read-char) (cons c a))))))
                   str)
             (delete-file fname)))))
+
+(test.only "ports: read after exception"
+      (lambda (t)
+        (let ((fname "./tests/__x8__.scm")
+              (str "Lorem")
+              (port #f))
+          (if (file-exists? fname)
+              (delete-file fname))
+          (call-with-output-file fname (lambda (p) (write str p)))
+          (call-with-input-file fname
+            (lambda (p)
+              (set! port p)
+              (+ 'a 'b)))
+          (t.is (read port) str)
+          (close-port port)
+          (delete-file fname))))