Hi all,
since there where no more responses on my last post to this thread, I
decided that it might be the best to supply a patch to this list, which
adds a procedure "make-shared-parameter" extending the existing
make-parameter in a compatible way. The attached diff (against svn
revision 11597) should have no impact on the standard procedure
make-parameter and the parameterize macro. However if the parameter is
a shared parameter, only parameterize will create a local binding for
that parameter (or the to-be-undocumented interface: call the parameter
procedure with a second argument).
I'd appreciate if this could make it into the chicken core - otherwise
it's going to be a pain to set up a clean build environment in my case.
Best regards
/Jörg
Index: debian/rules
===================================================================
--- debian/rules (Revision 11596)
+++ debian/rules (Arbeitskopie)
@@ -17,6 +17,7 @@
dh_testdir
$(MAKE) \
USE_HOST_PCRE=1 \
+ DEBUGBUILD=1 \
CFLAGS="$(CFLAGS)" \
PREFIX="$(PREFIX)" \
MANDIR="$(PREFIX)/share/man" \
@@ -66,7 +67,7 @@
# The asterisk in chicken.info* is necessary, because Debian makeinfo
# is very different from the standard makeinfo, and it is incredibly
# difficult to convince it to produce standalone Texinfo files.
- dh_installinfo chicken.info*
+# dh_installinfo chicken.info*
dh_installchangelogs ChangeLog.*
dh_install --sourcedir=debian/tmp
dh_link
Index: library.scm
===================================================================
--- library.scm (Revision 11596)
+++ library.scm (Arbeitskopie)
@@ -2036,8 +2036,14 @@
(define make-parameter
(let ([count 0])
- (lambda (init . guard)
- (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
+ (lambda (init . guard+type)
+ (let* ([guard (if (pair? guard+type) (##sys#slot guard+type 0) (lambda (x) x))]
+ [rest (and (pair? guard+type) (##sys#slot guard+type 1))]
+ [type (if (pair? rest)
+ (case (##sys#slot rest 0)
+ ((#:shared) #:shared)
+ (else (##sys#signal-hook #:syntax-error 'make-parameter (##sys#slot rest 0))))
+ #f)]
[val (guard init)]
[i count] )
(set! count (fx+ count 1))
@@ -2047,7 +2053,13 @@
(##sys#setslot ##sys#default-parameter-vector i val)
(lambda arg
(let ([n (##sys#size ##sys#current-parameter-vector)])
- (cond [(pair? arg)
+ (cond [(and (pair? arg) (eq? type #:shared) (null? (cdr arg)))
+ (if (or (fx>= i n)
+ (eq? (##sys#slot ##sys#current-parameter-vector i) ##sys#snafu))
+ (##sys#setslot ##sys#default-parameter-vector i (guard (##sys#slot arg 0)))
+ (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0))))
+ (##core#undefined) ]
+ [(pair? arg)
(when (fx>= i n)
(set! ##sys#current-parameter-vector
(##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
@@ -2061,6 +2073,8 @@
(##sys#slot ##sys#default-parameter-vector i)
val) ) ] ) ) ) ) ) ) )
+(define (make-shared-parameter init . guard)
+ (make-parameter init (if (pair? guard) (car guard) (lambda (v) v)) #:shared))
;;; Input:
Index: chicken-more-macros.scm
===================================================================
--- chicken-more-macros.scm (Revision 11596)
+++ chicken-more-macros.scm (Arbeitskopie)
@@ -213,7 +213,7 @@
[aliases2 (##sys#map (lambda (z) (gensym)) params)] )
`(let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
(let ((,swap (lambda ()
- ,@(map (lambda (a a2) `(let ((t (,a))) (,a ,a2) (##core#set! ,a2 t)))
+ ,@(map (lambda (a a2) `(let ((t (,a))) (,a ,a2 'local) (##core#set! ,a2 t)))
aliases aliases2) ) ) )
(##sys#dynamic-wind
,swap
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
