From 9bf39af5485c7c0f69d9331f7e75de2c65949666 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Mon, 16 May 2016 12:58:57 +0200
Subject: [PATCH] Make setters special-cased parameter setters compatible with
 new-style parameterize

If set? if #f it should not try to set the value.  This would prevent
parameterize from restoring the original value.

Fixes #1285
---
 library.scm             | 37 ++++++++++++++++++++++---------------
 tests/library-tests.scm | 21 +++++++++++++++++++++
 types.db                |  8 ++++----
 3 files changed, 47 insertions(+), 19 deletions(-)

diff --git a/library.scm b/library.scm
index 9238e59..10b43b0 100644
--- a/library.scm
+++ b/library.scm
@@ -1902,25 +1902,28 @@ EOF
       (##core#inline "C_i_check_port_2" x 0 #t (car loc))
       (##core#inline "C_i_check_port" x 0 #t) ) )
 
-(define (current-input-port . arg)
-  (when (pair? arg)
-    (let ([p (car arg)])
+(define (current-input-port . args)
+  (when (pair? args)
+    (let ((p (car args)))
       (##sys#check-port p 'current-input-port)
-      (set! ##sys#standard-input p) ))
+      (let-optionals (cdr args) ((convert? #t) (set? #t))
+	(when set? (set! ##sys#standard-input p))) ) )
   ##sys#standard-input)
 
-(define (current-output-port . arg)
-  (when (pair? arg)
-    (let ([p (car arg)])
+(define (current-output-port . args)
+  (when (pair? args)
+    (let ((p (car args)))
       (##sys#check-port p 'current-output-port)
-      (set! ##sys#standard-output p) ) )
+      (let-optionals (cdr args) ((convert? #t) (set? #t))
+	(when set? (set! ##sys#standard-output p))) ) )
   ##sys#standard-output)
 
-(define (current-error-port . arg)
-  (when (pair? arg)
-    (let ([p (car arg)])
+(define (current-error-port . args)
+  (when (pair? args)
+    (let ((p (car args)))
       (##sys#check-port p 'current-error-port)
-      (set! ##sys#standard-error p) ) )
+      (let-optionals (cdr args) ((convert? #t) (set? #t))
+	(when set? (set! ##sys#standard-error p))) ) )
   ##sys#standard-error)
 
 (define (##sys#tty-port? port)
@@ -4095,9 +4098,13 @@ EOF
       thunk
       (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
 
-(define (current-exception-handler #!optional proc)
-  (when proc
-    (set! ##sys#current-exception-handler proc))
+(define (current-exception-handler . args)
+  (when (pair? args)
+    (let ((proc (car args)))
+      (##sys#check-closure proc 'current-exception-handler)
+      (let-optionals (cdr args) ((convert? #t) (set? #t))
+	(when set?
+	  (set! ##sys#current-exception-handler proc))) ) )
   ##sys#current-exception-handler)
 
 (define (make-property-condition kind . props)
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index b37cfce..13f539d 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -528,6 +528,27 @@ A
 
   (assert (equal? (list "1" "2") (list (a) (b)))) )
 
+;; Special-cased parameters are reset correctly (#1285, regression
+;; caused by fix for #1227)
+
+(let ((original-input (current-input-port))
+      (original-output (current-output-port))
+      (original-error (current-error-port))
+      (original-exception-handler (current-exception-handler)))
+  (call-with-output-string
+   (lambda (out)
+     (call-with-input-string
+      "foo"
+      (lambda (in)
+	(parameterize ((current-output-port out)
+		       (current-error-port out)
+		       (current-input-port in)
+		       (current-exception-handler void))
+	  (void))))))
+  (assert (equal? original-input (current-input-port)))
+  (assert (equal? original-output (current-output-port)))
+  (assert (equal? original-error (current-error-port)))
+  (assert (equal? original-exception-handler (current-exception-handler))))
 
 ;;; vector and blob limits
 
diff --git a/types.db b/types.db
index b4a3887..73486fd 100644
--- a/types.db
+++ b/types.db
@@ -624,14 +624,14 @@
 (output-port? (#(procedure #:pure #:predicate output-port) output-port? (*) boolean))
 
 (current-input-port
- (#(procedure #:clean #:enforce) current-input-port (#!optional input-port) input-port)
+ (#(procedure #:clean #:enforce) current-input-port (#!optional input-port boolean boolean) input-port)
  ((input-port) (let ((#(tmp1) #(1))) 
 		 (let ((#(tmp2) (set! ##sys#standard-input #(tmp1))))
 		   #(tmp1))))
  (() ##sys#standard-input))
 
 (current-output-port
- (#(procedure #:clean #:enforce) current-output-port (#!optional output-port) output-port)
+ (#(procedure #:clean #:enforce) current-output-port (#!optional output-port boolean boolean) output-port)
  ((output-port) (let ((#(tmp1) #(1)))
 		  (let ((#(tmp2) (set! ##sys#standard-output #(tmp1))))
 		    #(tmp1))))
@@ -786,14 +786,14 @@
 (cpu-time (#(procedure #:clean) cpu-time () fixnum fixnum))
 
 (current-error-port
- (#(procedure #:clean #:enforce) current-error-port (#!optional output-port) output-port)
+ (#(procedure #:clean #:enforce) current-error-port (#!optional output-port boolean boolean) output-port)
  ((output-port) (let ((#(tmp1) #(1))) 
 		  (let ((#(tmp2) (set! ##sys#standard-error #(tmp1))))
 		    #(tmp1))))
  (() ##sys#standard-error))
 
 (current-exception-handler
- (#(procedure #:clean #:enforce) current-exception-handler (#!optional (procedure (*) noreturn)) procedure)
+ (#(procedure #:clean #:enforce) current-exception-handler (#!optional (procedure (*) noreturn) boolean boolean) procedure)
  ((procedure) (let ((#(tmp1) #(1))) 
 		(let ((#(tmp2) (set! ##sys#current-exception-handler #(tmp1))))
 		  #(tmp1))))
-- 
2.1.4