(module cells (cells make-cell-of cell-of? cell-empty? cell-prune!
                     make-cell cell cell? cell-ref cell-set!)
(import scheme
        (only chicken define-values condition-case case-lambda
              gensym getter-with-setter error))

(define-values (make-cell-of cell-of? cell-empty? cell-prune!)
  (let* ((type (gensym 'CELL))
         (state type))
    (values
      (lambda preds
        (case-lambda
          (() state)
          ((arg)
           (if (eq? arg type)
             (set! state arg) ; for type tests
             (let loop ((preds preds))
               (cond
                 ((null? preds)
                  (set! state arg))
                 (((car preds) arg)
                  (loop (cdr preds)))
                 (else
                   (error 'make-cell-of
                          "type test failed in setter"
                          (car preds)
                          arg))))))))
      (lambda preds
        (lambda (xpr)
          (or (eq? state type)
              (and (procedure? xpr)
                   (let (
                     (saved state)
                     (result? (condition-case
                                (eq? type (and (xpr type) (xpr)))
                                ((exn) #f)))
                     )
                     (set! state saved)
                     result?)
                   (let loop ((preds preds))
                     (cond
                       ((null? preds) #t)
                       (((car preds) state)
                        (loop (cdr preds)))
                       (else #f)))))))
      (lambda (xpr)
        (and ((cell-of?) xpr) (eq? state type)))
      (lambda (c%) (c% type))
      )))

(define (make-cell) (make-cell-of))

(define (cell init)
  (let ((c% (make-cell)))
    (c% init)
    c%))

(define (cell? xpr)
  ((cell-of?) xpr))

(define (cell-set! %c arg)
  (%c arg))

(define cell-ref (getter-with-setter (lambda (%c) (%c)) cell-set!))

(define cells
  (let ((signatures '((make-cell-of . predicates)
                      (cell-of? . predicates)
                      (cell-empty? xpr)
                      (cell-prune! %c)
                      (make-cell)
                      (cell init)
                      (cell? xpr)
                      (cell-ref cl)
                      (cell-set! cl val))))
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

) ; cells