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

(module variable-item

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

  (import
    scheme
    chicken
    (only data-structures identity)
    (only type-checks check-procedure check-symbol)
    (only type-errors warning-argument-type))

  (require-library type-checks type-errors)

;;

(define-syntax warning-guard
  (lambda (frm rnm cmp)
    (##sys#check-syntax 'warning-guard frm '(_ symbol symbol))
    (let ((?getnam (cadr frm))
          (?typnam (caddr frm)) )
      (let ((predname (string->symbol (string-append (symbol->string ?typnam) "?"))))
        `(,(rnm 'lambda) (obj)
          (,(rnm 'if) (,predname obj) obj
            (,(rnm 'begin)
              (,(rnm 'warning-argument-type) ',?getnam obj ',?typnam)
              (,?getnam) ) ) ) ) ) ) )

(define-syntax checked-guard
  (lambda (frm rnm cmp)
    (##sys#check-syntax 'checked-guard frm '(_ symbol symbol))
    (let ((?locnam (cadr frm))
          (?typnam (caddr frm)) )
      (let ((chknam (string->symbol (string-append "check-" (symbol->string ?typnam)))))
        `(,(rnm 'lambda) (obj) (,chknam ',?locnam obj)) ) ) ) )

;;

; 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
      (lambda args
        (if (null? args) value
          (setter (car args)) ) )
      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)
      (define-variable ?name ?init (warning-guard ?name ?typnam)) ) ) )

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

) ;module variable-item