~ chicken-core (chicken-5) cc0625c0a1dd5dcced8f63b9d4030ada49f0f066
commit cc0625c0a1dd5dcced8f63b9d4030ada49f0f066
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 29 08:59:56 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 29 08:59:56 2010 -0400
make parameters settable (fixes #315)
diff --git a/library.scm b/library.scm
index c62db6a3..e38a66f8 100644
--- a/library.scm
+++ b/library.scm
@@ -1979,38 +1979,175 @@ EOF
#:rename new) )
+;;; Decorate procedure with arbitrary data
+
+(define (##sys#decorate-lambda proc pred decorator)
+ (let ((len (##sys#size proc)))
+ (let loop ((i (fx- len 1)))
+ (cond ((zero? i)
+ (let ((p2 (make-vector (fx+ len 1))))
+ (do ((i 1 (fx+ i 1)))
+ ((fx>= i len)
+ (##core#inline "C_vector_to_closure" p2)
+ (##core#inline "C_copy_pointer" proc p2)
+ (decorator p2 i) )
+ (##sys#setslot p2 i (##sys#slot proc i)) ) ) )
+ (else
+ (let ((x (##sys#slot proc i)))
+ (if (pred x)
+ (decorator proc i)
+ (loop (fx- i 1)) ) ) ) ) ) ) )
+
+(define (##sys#lambda-decoration proc pred)
+ (let loop ((i (fx- (##sys#size proc) 1)))
+ (and (fx> i 0)
+ (let ((x (##sys#slot proc i)))
+ (if (pred x)
+ x
+ (loop (fx- i 1)) ) ) ) ) )
+
+
+;;; Create lambda-info object
+
+(define (##sys#make-lambda-info str)
+ (let* ((sz (##sys#size str))
+ (info (##sys#make-string sz)) )
+ (##core#inline "C_copy_memory" info str sz)
+ (##core#inline "C_string_to_lambdainfo" info)
+ info) )
+
+
+;;; Function debug info:
+
+(define (##sys#lambda-info? x)
+ (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
+
+(define (##sys#lambda-info proc)
+ (##sys#lambda-decoration proc ##sys#lambda-info?))
+
+(define (##sys#lambda-info->string info)
+ (let* ((sz (##sys#size info))
+ (s (##sys#make-string sz)) )
+ (##core#inline "C_copy_memory" s info sz)
+ s) )
+
+(define procedure-information
+ (lambda (x)
+ (##sys#check-closure x 'procedure-information)
+ (and-let* ((info (##sys#lambda-info x)))
+ (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) )
+
+
+;;; SRFI-17
+
+(define setter-tag (vector 'setter))
+
+(define-inline (setter? x)
+ (and (pair? x) (eq? setter-tag (##sys#slot x 0))) )
+
+(define ##sys#setter
+ (##sys#decorate-lambda
+ (lambda (proc)
+ (or (and-let* (((procedure? proc))
+ (d (##sys#lambda-decoration proc setter?)) )
+ (##sys#slot d 1) )
+ (##sys#error 'setter "no setter defined" proc) ) )
+ setter?
+ (lambda (proc i)
+ (##sys#setslot
+ proc i
+ (cons
+ setter-tag
+ (lambda (get set)
+ (if (procedure? get)
+ (let ((get2 (##sys#decorate-lambda
+ get
+ setter?
+ (lambda (proc i) (##sys#setslot proc i (cons setter-tag set)) proc))))
+ (if (eq? get get2)
+ get
+ (##sys#become! (list (cons get get2))) ) )
+ (error "can't set setter of non-procedure" get) ) ) ) )
+ proc) ) )
+
+(define setter ##sys#setter)
+
+(define (getter-with-setter get set #!optional info)
+ (let ((getdec (cond (info
+ (##sys#check-string info 'getter-with-setter)
+ (##sys#make-lambda-info info))
+ (else (##sys#lambda-info get))))
+ (p1 (##sys#decorate-lambda
+ get
+ setter?
+ (lambda (proc i)
+ (##sys#setslot proc i (cons setter-tag set))
+ proc) )))
+ (if getdec
+ (##sys#decorate-lambda
+ p1
+ ##sys#lambda-info?
+ (lambda (p i)
+ (##sys#setslot p i getdec)
+ p))
+ p1)))
+
+(set! car (getter-with-setter car set-car! "(car p)"))
+(set! cdr (getter-with-setter cdr set-cdr! "(cdr p)"))
+(set! caar (getter-with-setter caar (lambda (x y) (set-car! (car x) y)) "(caar p)"))
+(set! cadr (getter-with-setter cadr (lambda (x y) (set-car! (cdr x) y)) "(cadr p)"))
+(set! cdar (getter-with-setter cdar (lambda (x y) (set-cdr! (car x) y)) "(cdar p)"))
+(set! cddr (getter-with-setter cddr (lambda (x y) (set-cdr! (cdr x) y)) "(cddr p)"))
+(set! caaar (getter-with-setter caaar (lambda (x y) (set-car! (caar x) y)) "(caaar p)"))
+(set! caadr (getter-with-setter caadr (lambda (x y) (set-car! (cadr x) y)) "(caadr p)"))
+(set! cadar (getter-with-setter cadar (lambda (x y) (set-car! (cdar x) y)) "(cadar p)"))
+(set! caddr (getter-with-setter caddr (lambda (x y) (set-car! (cddr x) y)) "(caddr p)"))
+(set! cdaar (getter-with-setter cdaar (lambda (x y) (set-cdr! (caar x) y)) "(cdaar p)"))
+(set! cdadr (getter-with-setter cdadr (lambda (x y) (set-cdr! (cadr x) y)) "(cdadr p)"))
+(set! cddar (getter-with-setter cddar (lambda (x y) (set-cdr! (cdar x) y)) "(cddar p)"))
+(set! cdddr (getter-with-setter cdddr (lambda (x y) (set-cdr! (cddr x) y)) "(cdddr p)"))
+(set! string-ref (getter-with-setter string-ref string-set! "(string-ref str i)"))
+(set! vector-ref (getter-with-setter vector-ref vector-set! "(vector-ref vec i)"))
+
+
;;; Parameters:
(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
(define ##sys#current-parameter-vector '#())
(define make-parameter
- (let ([count 0])
+ (let ((count 0))
(lambda (init . guard)
- (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
- [val (guard init)]
- [i count] )
+ (let* ((guard (if (pair? guard) (car guard) (lambda (x) x)))
+ (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#setslot ##sys#default-parameter-vector i val)
- (lambda arg
- (let ([n (##sys#size ##sys#current-parameter-vector)])
- (cond [(pair? arg)
- (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 (##sys#slot arg 0)))
- (##core#undefined) ]
- [(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) ) ] ) ) ) ) ) ) )
-
+ (let ((assign
+ (lambda (val n)
+ (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))
+ (##core#undefined) )))
+ (getter-with-setter
+ (lambda arg
+ (let ((n (##sys#size ##sys#current-parameter-vector)))
+ (cond ((pair? arg) (assign (car arg) n))
+ ((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)))))))))
+
;;; Input:
@@ -4465,137 +4602,6 @@ EOF
(vector hsize (fx- hsize free) (##sys#slot info 1)) ) )
-;;; Decorate procedure with arbitrary data
-
-(define (##sys#decorate-lambda proc pred decorator)
- (let ((len (##sys#size proc)))
- (let loop ((i (fx- len 1)))
- (cond ((zero? i)
- (let ((p2 (make-vector (fx+ len 1))))
- (do ((i 1 (fx+ i 1)))
- ((fx>= i len)
- (##core#inline "C_vector_to_closure" p2)
- (##core#inline "C_copy_pointer" proc p2)
- (decorator p2 i) )
- (##sys#setslot p2 i (##sys#slot proc i)) ) ) )
- (else
- (let ((x (##sys#slot proc i)))
- (if (pred x)
- (decorator proc i)
- (loop (fx- i 1)) ) ) ) ) ) ) )
-
-(define (##sys#lambda-decoration proc pred)
- (let loop ((i (fx- (##sys#size proc) 1)))
- (and (fx> i 0)
- (let ((x (##sys#slot proc i)))
- (if (pred x)
- x
- (loop (fx- i 1)) ) ) ) ) )
-
-
-;;; Create lambda-info object
-
-(define (##sys#make-lambda-info str)
- (let* ((sz (##sys#size str))
- (info (##sys#make-string sz)) )
- (##core#inline "C_copy_memory" info str sz)
- (##core#inline "C_string_to_lambdainfo" info)
- info) )
-
-
-;;; Function debug info:
-
-(define (##sys#lambda-info? x)
- (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
-
-(define (##sys#lambda-info proc)
- (##sys#lambda-decoration proc ##sys#lambda-info?))
-
-(define (##sys#lambda-info->string info)
- (let* ((sz (##sys#size info))
- (s (##sys#make-string sz)) )
- (##core#inline "C_copy_memory" s info sz)
- s) )
-
-(define procedure-information
- (lambda (x)
- (##sys#check-closure x 'procedure-information)
- (and-let* ((info (##sys#lambda-info x)))
- (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) )
-
-
-;;; SRFI-17
-
-(define setter-tag (vector 'setter))
-
-(define-inline (setter? x)
- (and (pair? x) (eq? setter-tag (##sys#slot x 0))) )
-
-(define ##sys#setter
- (##sys#decorate-lambda
- (lambda (proc)
- (or (and-let* (((procedure? proc))
- (d (##sys#lambda-decoration proc setter?)) )
- (##sys#slot d 1) )
- (##sys#error 'setter "no setter defined" proc) ) )
- setter?
- (lambda (proc i)
- (##sys#setslot
- proc i
- (cons
- setter-tag
- (lambda (get set)
- (if (procedure? get)
- (let ((get2 (##sys#decorate-lambda
- get
- setter?
- (lambda (proc i) (##sys#setslot proc i (cons setter-tag set)) proc))))
- (if (eq? get get2)
- get
- (##sys#become! (list (cons get get2))) ) )
- (error "can't set setter of non-procedure" get) ) ) ) )
- proc) ) )
-
-(define setter ##sys#setter)
-
-(define (getter-with-setter get set #!optional info)
- (let ((getdec (cond (info
- (##sys#check-string info 'getter-with-setter)
- (##sys#make-lambda-info info))
- (else (##sys#lambda-info get))))
- (p1 (##sys#decorate-lambda
- get
- setter?
- (lambda (proc i)
- (##sys#setslot proc i (cons setter-tag set))
- proc) )))
- (if getdec
- (##sys#decorate-lambda
- p1
- ##sys#lambda-info?
- (lambda (p i)
- (##sys#setslot p i getdec)
- p))
- p1)))
-
-(set! car (getter-with-setter car set-car! "(car p)"))
-(set! cdr (getter-with-setter cdr set-cdr! "(cdr p)"))
-(set! caar (getter-with-setter caar (lambda (x y) (set-car! (car x) y)) "(caar p)"))
-(set! cadr (getter-with-setter cadr (lambda (x y) (set-car! (cdr x) y)) "(cadr p)"))
-(set! cdar (getter-with-setter cdar (lambda (x y) (set-cdr! (car x) y)) "(cdar p)"))
-(set! cddr (getter-with-setter cddr (lambda (x y) (set-cdr! (cdr x) y)) "(cddr p)"))
-(set! caaar (getter-with-setter caaar (lambda (x y) (set-car! (caar x) y)) "(caaar p)"))
-(set! caadr (getter-with-setter caadr (lambda (x y) (set-car! (cadr x) y)) "(caadr p)"))
-(set! cadar (getter-with-setter cadar (lambda (x y) (set-car! (cdar x) y)) "(cadar p)"))
-(set! caddr (getter-with-setter caddr (lambda (x y) (set-car! (cddr x) y)) "(caddr p)"))
-(set! cdaar (getter-with-setter cdaar (lambda (x y) (set-cdr! (caar x) y)) "(cdaar p)"))
-(set! cdadr (getter-with-setter cdadr (lambda (x y) (set-cdr! (cadr x) y)) "(cdadr p)"))
-(set! cddar (getter-with-setter cddar (lambda (x y) (set-cdr! (cdar x) y)) "(cddar p)"))
-(set! cdddr (getter-with-setter cdddr (lambda (x y) (set-cdr! (cddr x) y)) "(cdddr p)"))
-(set! string-ref (getter-with-setter string-ref string-set! "(string-ref str i)"))
-(set! vector-ref (getter-with-setter vector-ref vector-set! "(vector-ref vec i)"))
-
-
;;; Property lists
(define (##sys#put! sym prop val)
diff --git a/manual/Parameters b/manual/Parameters
index 2d9b22ca..8e21811f 100644
--- a/manual/Parameters
+++ b/manual/Parameters
@@ -3,11 +3,12 @@
== Parameters
-Parameters are Chicken's form of dynamic variables, except that they are
-procedures rather than actual variables. A parameter is a procedure of
-zero or one arguments. To retrieve the value of a parameter call the
-parameter-procedure with zero arguments. To change the setting of the
-parameter, call the parameter-procedure with the new value as argument:
+Parameters are a form of dynamic variables, except that they are
+procedures rather than actual variables. A parameter is a procedure
+of zero or one arguments. To retrieve the value of a parameter call
+the parameter-procedure with zero arguments. To change the setting of
+the parameter, call the parameter-procedure with the new value as
+argument:
<enscript highlight=scheme>
(define foo (make-parameter 123))
@@ -16,11 +17,18 @@ parameter, call the parameter-procedure with the new value as argument:
(foo) ==> 99
</enscript>
-Parameters are fully thread-local, each thread of execution
-owns a local copy of a parameters' value.
+Parameters are fully thread-local, each thread of execution owns a
+local copy of a parameters' value.
CHICKEN implements [[http://srfi.schemers.org/srfi-39/srfi-39.html|SRFI-39]].
+Parameters are "settable", in other words, you can also write
+
+<enscript highlight=scheme>
+(set! (foo) 100)
+</enscript>
+
+to assign a new value.
=== make-parameter
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index cf3f1f37..58d13e00 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -125,3 +125,15 @@
(assert (string=? "abc" (symbol->string (with-input-from-string "aBc" read))))
(assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
(assert (string=? "aBc" (symbol->string (with-input-from-string "a\\Bc" read)))))
+
+
+;;; setters
+
+(define x '(a b c))
+(define kar car)
+(set! (kar (cdr x)) 99)
+(assert (equal? '(a 99 c) x))
+(define p (make-parameter 100))
+(assert (= 100 (p)))
+(set! (p) 1000)
+(assert (= 1000 (p)))
Trap