~ chicken-core (chicken-5) a94b69e52433708179d34098cae12f352a01d33b
commit a94b69e52433708179d34098cae12f352a01d33b
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 23 15:10:26 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Feb 9 19:02:11 2016 +1300
Fix nonlocal exit handling in parameterize
When a parameter's "guard" procedure raises an exception, the values
should be consistent. Before, the values were assigned one by one, and
if the exception got raised halfway through, the already-assigned
parameters would not be restored to their original values.
Add a clarifying comment as to why we must alias all the parameters:
they don't need to be identifiers but can be complex expressions
evaluating to parameters. This is not immediately obvious from the
code. It's only clear when you remember that parameterize can be used
like this when reading the code.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 777a6be8..fcdbe1c9 100644
--- a/NEWS
+++ b/NEWS
@@ -28,6 +28,9 @@
- Core libraries
- SRFI-18: thread-join! no longer gives an error when passed a
thread in the "sleeping" state (thanks to Joerg Wittenberger)
+ - SRFI-39: When a parameter's "guard" procedure raises an exception,
+ "parameterize" now correctly resets the original values of all
+ parameters (fixes #1227, thanks to Joo ChurlSoo).
- Irregex has been updated to 0.9.4, which fixes severe performance
problems with {n,m} repeating patterns (thanks to Caolan McMahon).
- Unit "posix": The following posix procedures now work on port
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 11ecda23..f3ee9c81 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -280,25 +280,36 @@
(let* ((bindings (cadr form))
(body (cddr form))
(swap (r 'swap))
- (mode (r 'mode))
+ (convert? (r 'convert?))
(params (##sys#map car bindings))
(vals (##sys#map cadr bindings))
- (aliases (##sys#map (lambda (z) (r (pname z))) params))
- (aliases2 (##sys#map (lambda (z) (r (gensym))) params)) )
+ (param-aliases (##sys#map (lambda (z) (r (pname z))) params))
+ (saveds (##sys#map (lambda (z) (r (gensym 'saved))) params))
+ (temps (##sys#map (lambda (z) (r (gensym 'tmp))) params)) )
`(##core#let
- ,(map ##sys#list aliases params)
+ ,(map ##sys#list param-aliases params) ; These may be expressions
(##core#let
- ,(map ##sys#list aliases2 vals)
+ ,(map ##sys#list saveds vals)
(##core#let
- ((,mode #f))
+ ((,convert? #t))
(##core#let
((,swap (##core#lambda
()
- ,@(map (lambda (a a2)
- `(##core#let ((t (,a))) (,a ,a2 ,mode)
- (##core#set! ,a2 t)))
- aliases aliases2)
- (##core#set! ,mode #t))))
+ (##core#let
+ ;; First, convert all (converters may throw exns)
+ (,@(map (lambda (p s t)
+ `(,t (##core#if ,convert?
+ (,p ,s #t #f)
+ ,s)))
+ param-aliases saveds temps))
+ ;; Save current values so we can restore them
+ ,@(map (lambda (p s) `(##core#set! ,s (,p)))
+ param-aliases saveds)
+ ;; Now set params to their new values (can't fail)
+ ,@(map (lambda (p t) `(,p ,t #f #t))
+ param-aliases temps)
+ ;; And toggle conversion
+ (##core#set! ,convert? #f)))))
(##sys#dynamic-wind
,swap
(##core#lambda () ,@body)
diff --git a/library.scm b/library.scm
index 9fa47610..141bffe0 100644
--- a/library.scm
+++ b/library.scm
@@ -2247,42 +2247,46 @@ EOF
(define make-parameter
(let ((count 0))
(lambda (init #!optional (guard (lambda (x) x)))
- (let ((val (guard init))
- (i count))
+ (let* ((val (guard init))
+ (i count)
+ (assign (lambda (val n convert? set?)
+ (when (fx>= i n)
+ (set! ##sys#current-parameter-vector
+ (##sys#vector-resize
+ ##sys#current-parameter-vector
+ (fx+ i 1)
+ ##sys#snafu) ) )
+ (let ((val (if convert? (guard val) val)))
+ (when set?
+ (##sys#setslot ##sys#current-parameter-vector i val))
+ val))))
+
(set! count (fx+ count 1))
(when (fx>= i (##sys#size ##sys#default-parameter-vector))
- (set! ##sys#default-parameter-vector
+ (set! ##sys#default-parameter-vector
(##sys#vector-resize
##sys#default-parameter-vector
(fx+ i 1)
(##core#undefined)) ) )
(##sys#setslot ##sys#default-parameter-vector i val)
- (let ((assign
- (lambda (val n mode)
- (when (fx>= i n)
- (set! ##sys#current-parameter-vector
- (##sys#vector-resize
- ##sys#current-parameter-vector
- (fx+ i 1)
- ##sys#snafu) ) )
- (let ((val (if mode val (guard val))))
- (##sys#setslot ##sys#current-parameter-vector i val)
- val))))
- (getter-with-setter
- (lambda args
- (let ((n (##sys#size ##sys#current-parameter-vector)))
- (cond ((pair? args)
- (assign (car args) n (optional (cdr args) #f)))
- ((fx>= i n)
- (##sys#slot ##sys#default-parameter-vector i) )
- (else
- (let ((val (##sys#slot ##sys#current-parameter-vector i)))
- (if (eq? val ##sys#snafu)
- (##sys#slot ##sys#default-parameter-vector i)
- val) ) ) ) ) )
- (lambda (val)
- (let ((n (##sys#size ##sys#current-parameter-vector)))
- (assign val n #f)))))))))
+
+ (getter-with-setter
+ (lambda args
+ (let ((n (##sys#size ##sys#current-parameter-vector)))
+ (cond ((pair? args)
+ (let-optionals (cdr args) ((convert? #t)
+ (set? #t))
+ (assign (car args) n convert? set?)))
+ ((fx>= i n)
+ (##sys#slot ##sys#default-parameter-vector i) )
+ (else
+ (let ((val (##sys#slot ##sys#current-parameter-vector i)))
+ (if (eq? val ##sys#snafu)
+ (##sys#slot ##sys#default-parameter-vector i)
+ val) ) ) ) ) )
+ (lambda (val)
+ (let ((n (##sys#size ##sys#current-parameter-vector)))
+ (assign val n #f #t))))))))
;;; Input:
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index bbe27191..b37cfce1 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -508,6 +508,27 @@ A
(assert (= 2 guard-called))
+;; Parameters are reset correctly (#1227, pointed out by Joo ChurlSoo)
+
+(let ((a (make-parameter 1 number->string))
+ (b (make-parameter 2 number->string)))
+ (assert (equal? (list "1" "2") (list (a) (b))))
+
+ (assert (equal? (list "10" "20")
+ (parameterize ((a 10) (b 20)) (list (a) (b)))))
+
+ (assert (equal? (list "1" "2") (list (a) (b))))
+
+ (handle-exceptions exn #f (parameterize ((a 10) (b 'x)) (void)))
+
+ (assert (equal? (list "1" "2") (list (a) (b))))
+
+ (parameterize ((a 10) (b 30) (a 20))
+ (assert (equal? (list "20" "30") (list (a) (b)))))
+
+ (assert (equal? (list "1" "2") (list (a) (b)))) )
+
+
;;; vector and blob limits
(assert-fail (make-blob -1))
Trap