;; A modified SRFI-39
;; CASE-LAMBDA can be substituted for LAMBDA according to implementations.

;; by Joo ChurlSoo

;; eggified by felix


(module fluids (make-fluid (fluids aux-fluids))

(import scheme chicken)


(define fluid-fluids
  (let ((env '()))
    (cons (lambda (init . conv)
	    (cond
	     ((null? conv)
	      (let ((val init))
		(letrec ((fp (lambda args
			       (cond
				((null? args)
				 (cond
				  ((assq fp env) => (lambda (pair) (cdr pair)))
				  (else val)))
				((null? (cdr args))
				 (if env
				     (cond
				      ((assq fp env) => (lambda (pair) (set-cdr! pair (car args))))
				      (else (set! val (car args))))
				     (car args)))
				(else (error "fluid: too many arguments"))))))
		  fp)))
	     ((null? (cdr conv))
	      (let* ((converter (car conv))
		     (val (converter init)))
		(letrec ((fp (lambda args
			       (cond
				((null? args)
				 (cond
				  ((assq fp env) => (lambda (pair) (cdr pair)))
				  (else val)))
				((null? (cdr args))
				 (if env
				     (cond
				      ((assq fp env) => (lambda (pair) (set-cdr! pair (converter (car args)))))
				      (else (set! val (converter (car args)))))
				     (converter (car args))))
				(else (error "fluid: too many arguments"))))))
		  fp)))
	     (else (error "make-fluid: too many arguments" conv))))
	  (lambda (fls vls body)
	    (let* ((old-env env)
		   (new-env
		    (dynamic-wind	;for error
			(lambda () (set! env #f))
			(lambda ()
			  (let lp ((fls fls) (vls vls) (new-env old-env))
			    (if (null? fls)
				new-env
				(lp (cdr fls)
				    (cdr vls)
				    (cons (cons (car fls) ((car fls) (car vls)))
					  new-env)))))
			(lambda () (set! env old-env)))))
	      (dynamic-wind
		  (lambda () (set! env new-env))
		  body
		  (lambda () (set! env old-env))))))))

(define make-fluid (car fluid-fluids))
(define aux-fluids (cdr fluid-fluids))

(define-syntax fluids
  (syntax-rules ()
    ((fluids ((f v) ...) body ...)
     (aux-fluids (list f ...) (list v ...) (lambda () body ...)))))
;; (define-macro (fluids args . body)
;;   `(aux-fluids (list ,@(map car args))
;; 	       (list ,@(map cadr args))
;; 	       (lambda () ,@body)))


)

;;; eof