(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)))
    (values
      (lambda preds ; constructor
        (let ((state type))
          (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 ; predicate
        (lambda (xpr)
          (and (procedure? xpr)
               (condition-case
                 (let ((saved (xpr)) ; save state
                       (result? (eq? type (and (xpr type) (xpr)))))
                   (xpr saved) ; restore state
                   result?)
                 ((exn) #f))
               (if (eq? type (xpr))
                 #t
                 (let loop ((preds preds))
                   (cond
                     ((null? preds) #t)
                     (((car preds) (xpr))
                      (loop (cdr preds)))
                     (else #f)))))))
      (lambda (xpr) ; empty?
        (and ((cell-of?) xpr) (eq? type (xpr))))
      (lambda (c%) ; prune!
        (if ((cell-of?) c%)
          (c% type)
          (error 'cell-prune! "not a cell" c%)))
      )))

(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