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

(module variable-item

(;export
  ;
  (define-variable make-variable)
  make-variable
  define-warning-variable
  define-checked-variable
  ;
  #; ;NOT READY
  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 ...)) ) ) )

;;

#; ;NOT READY
;(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))
            (_apply (ren 'apply))
            (_begin (ren 'begin))
            (_receive (ren 'receive))
            (_values (ren 'values))
            (_vals (ren 'vals)) )
        (let ((bnds (map (lambda (bnd)
                           `(,(symbol-append (gensym) (car bnd)) (,(car bnd))) )
                         ?vars)) )
          ;FIXME {{unwind-protect}}
          `(,_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