~ chicken-core (chicken-5) 70e53184f9a530905011503a0a90c21919202cdb
commit 70e53184f9a530905011503a0a90c21919202cdb
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 1 08:51:59 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 1 08:51:59 2011 +0200
additional parameter-argument determines whether guard proc should be called or not
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index aea116fd..edcb0970 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -276,28 +276,32 @@
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'parameterize form '#(_ 2))
- (let* ((bindings (cadr form))
- (body (cddr form))
- (swap (r 'swap))
- [params (##sys#map car bindings)]
- [vals (##sys#map cadr bindings)]
- [aliases (##sys#map (lambda (z) (r (gensym))) params)]
- [aliases2 (##sys#map (lambda (z) (r (gensym))) params)] )
- `(##core#let
- ,(##sys#append
- (map ##sys#list aliases params)
- (map ##sys#list aliases2 vals))
+ (let* ((bindings (cadr form))
+ (body (cddr form))
+ (swap (r 'swap))
+ (mode (r 'mode))
+ (params (##sys#map car bindings))
+ (vals (##sys#map cadr bindings))
+ (aliases (##sys#map (lambda (z) (r (gensym))) params))
+ (aliases2 (##sys#map (lambda (z) (r (gensym))) params)) )
+ `(##core#let
+ ,(map ##sys#list aliases params)
+ (##core#let
+ ,(map ##sys#list aliases2 vals)
+ (##core#let
+ ((,mode #f))
(##core#let
((,swap (##core#lambda
()
,@(map (lambda (a a2)
- `(##core#let ((t (,a))) (,a ,a2)
+ `(##core#let ((t (,a))) (,a ,a2 ,mode)
(##core#set! ,a2 t)))
- aliases aliases2) ) ) )
+ aliases aliases2)
+ (##core#set! ,mode #t))))
(##sys#dynamic-wind
,swap
(##core#lambda () ,@body)
- ,swap) ) ) ) )))
+ ,swap) ) ) ) )))))
(##sys#extend-macro-environment
'when '()
diff --git a/library.scm b/library.scm
index 4b5ff135..6399e284 100644
--- a/library.scm
+++ b/library.scm
@@ -2160,26 +2160,32 @@ EOF
(define make-parameter
(let ((count 0))
- (lambda (init . guard)
- (let* ((guard (if (pair? guard) (car guard) (lambda (x) x)))
- (val (guard init))
- (i count))
+ (lambda (init #!optional (guard (lambda (x) x)))
+ (let ((val (guard init))
+ (i count))
(set! count (fx+ count 1))
(when (fx>= i (##sys#size ##sys#default-parameter-vector))
(set! ##sys#default-parameter-vector
- (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
+ (##sys#grow-vector
+ ##sys#default-parameter-vector
+ (fx+ i 1)
+ (##core#undefined)) ) )
(##sys#setslot ##sys#default-parameter-vector i val)
(let ((assign
- (lambda (val n)
+ (lambda (val n mode)
(when (fx>= i n)
(set! ##sys#current-parameter-vector
- (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
- (##sys#setslot ##sys#current-parameter-vector i (guard val))
+ (##sys#grow-vector
+ ##sys#current-parameter-vector
+ (fx+ i 1)
+ ##sys#snafu) ) )
+ (##sys#setslot ##sys#current-parameter-vector i (if mode val (guard val)))
(##core#undefined) )))
(getter-with-setter
- (lambda arg
+ (lambda args
(let ((n (##sys#size ##sys#current-parameter-vector)))
- (cond ((pair? arg) (assign (car arg) n))
+ (cond ((pair? args)
+ (assign (car args) n (optional (cdr args) #f)))
((fx>= i n)
(##sys#slot ##sys#default-parameter-vector i) )
(else
@@ -2189,7 +2195,7 @@ EOF
val) ) ) ) ) )
(lambda (val)
(let ((n (##sys#size ##sys#current-parameter-vector)))
- (assign val n)))))))))
+ (assign val n #f)))))))))
;;; Input:
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 8aa5441c..7a491a07 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -229,3 +229,26 @@
(assert (equal=? '#(1 2 (3)) '#(1 2 (3))))
(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3)))))
(assert (not (equal=? 123 '(123))))
+
+;;; parameters
+
+(define guard-called 0)
+
+(define p
+ (make-parameter
+ 1
+ (lambda (x)
+ (set! guard-called (+ guard-called 1))
+ x)))
+
+(define k
+ (parameterize ((p 2))
+ (call/cc
+ (lambda (k)
+ (assert (= 2 (p)))
+ k))))
+
+(k #f)
+
+(assert (= 2 guard-called))
+
Trap