~ chicken-core (chicken-5) 9ace4ecce1445b795116066e2696cae29aeacdd3

commit 9ace4ecce1445b795116066e2696cae29aeacdd3
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Mon May 16 12:58:57 2016 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sun May 22 12:57:18 2016 +0200

    Make 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
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/library.scm b/library.scm
index 9238e595..10b43b0e 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 b37cfce1..13f539dd 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 5daa8e26..784dcf29 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))))