;;;; variable-item.scm  -*- Hen -*-
;;;; Kon Lovett, Aug '10

(module variable-item

(;export
  ;
  (define-variable make-variable)
  make-variable
  define-warning-variable
  define-checked-variable
  ;
  fluid-variable)

(import scheme
  (chicken base)
  (chicken syntax)
  (only moremacros warning-guard checked-guard))

;;

; not too proud of the name `variable' but ...

(define (make-variable init #!optional (guard identity))
  (let ((value (guard init)))
    (define (setter obj) (set! value (guard obj)))
    (getter-with-setter
      ;ugly but like parameter
      (lambda args
        (if (null? args) value
            (let ((new (car args)))
              (setter new)
              new ) ) )
      ;emphasize not a paramter
      setter) ) )

(define-syntax define-variable
  (syntax-rules ()
    ((_ ?name ?init) (define ?name (make-variable ?init)) )
    ((_ ?name ?init ?guard) (define ?name (make-variable ?init ?guard)) ) ) )

(define-syntax define-warning-variable
  (syntax-rules ()
    ((_ ?name ?init ?typnam ?body0 ...)
      (define-variable ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )

(define-syntax define-checked-variable
  (syntax-rules ()
    ((_ ?name ?init ?typnam ?body0 ...)
      (define-variable ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )

;;

;(fluid-variable ((?var0 ?val0) ...) ?body ...)
;
(define-syntax fluid-variable
  (er-macro-transformer
    (lambda (exp ren cmp)
      (let ((?vars (cadr exp))
            (?body (cddr exp))
            (_let (ren 'let)) )
        (let ((bnds
                (map
                  (lambda (bnd)
                    `(,(symbol-append (gensym) (car bnd)) (,(car bnd))))
                ?vars)) )
          `(,_let (,@bnds)
            ,@(map (lambda (bnd) `(,(car bnd) ,(cadr bnd))) ?vars)
            (,_let ((vals (receive (begin ,@?body))))
              ,@(map (lambda (bnd) `(,(caadr bnd) ,(car bnd))) bnds)
              (apply values vals)) ) ) ) ) ) )

) ;module variable-item