summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-12-01 23:31:50 +0100
committerAndy Wingo <wingo@pobox.com>2011-12-01 23:31:50 +0100
commitb2208d2e987759270c712e35c8164394a47a52aa (patch)
tree1edd39e74a266fc53c075d328696e8fbf33eba5b /module/srfi
parent3dc9f41900a0e9f915da3aa1eea6e0fae829c40d (diff)
parent738c899e4c1ab9d25cfbcd1010f34e0cce400bca (diff)
downloadguile-b2208d2e987759270c712e35c8164394a47a52aa.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: configure.ac libguile/fluids.c libguile/gc.c libguile/gc.h libguile/objcodes.c libguile/procprop.c libguile/vm.c module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm
Diffstat (limited to 'module/srfi')
-rw-r--r--module/srfi/srfi-39.scm50
1 files changed, 27 insertions, 23 deletions
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index dba86fdbb..d1c46d028 100644
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@@ -57,37 +57,41 @@
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
(define (make-parameter/helper val conv)
- (let ((value (make-fluid))
- (conv conv))
- (begin
- (fluid-set! value (conv val))
- (lambda new-value
- (cond
- ((null? new-value) (fluid-ref value))
- ((eq? (car new-value) get-fluid-tag) value)
- ((eq? (car new-value) get-conv-tag) conv)
- ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
- (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
+ (let ((fluid (make-fluid (conv val))))
+ (case-lambda
+ (()
+ (fluid-ref fluid))
+ ((new-value)
+ (cond
+ ((eq? new-value get-fluid-tag) fluid)
+ ((eq? new-value get-conv-tag) conv)
+ (else (fluid-set! fluid (conv new-value))))))))
(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
(with-parameters* (list ?param ...)
(list ?value ...)
(lambda () ?body ...)))
-(define (current-input-port . new-value)
- (if (null? new-value)
- ((@ (guile) current-input-port))
- (apply set-current-input-port new-value)))
+(define current-input-port
+ (case-lambda
+ (()
+ ((@ (guile) current-input-port)))
+ ((new-value)
+ (set-current-input-port new-value))))
-(define (current-output-port . new-value)
- (if (null? new-value)
- ((@ (guile) current-output-port))
- (apply set-current-output-port new-value)))
+(define current-output-port
+ (case-lambda
+ (()
+ ((@ (guile) current-output-port)))
+ ((new-value)
+ (set-current-output-port new-value))))
-(define (current-error-port . new-value)
- (if (null? new-value)
- ((@ (guile) current-error-port))
- (apply set-current-error-port new-value)))
+(define current-error-port
+ (case-lambda
+ (()
+ ((@ (guile) current-error-port)))
+ ((new-value)
+ (set-current-error-port new-value))))
(define port-list
(list current-input-port current-output-port current-error-port))