; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2014, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 
; Last update: Mar 14, 2014
;

(module cells
(export cell cell? cell-of?)
(import scheme
        (only chicken case-lambda condition-case define-values
              define-reader-ctor gensym))

(define-values (cell cell?)
  (let ((type (gensym 'cell)))
    (values
      (lambda (val)
        (let ((var val))
          (case-lambda
            (() var)
            ((val)
             (if (and (symbol? val) (eq? val type))
               type ;can never happen with client input
               (set! var val))))))
      (lambda (xpr)
        (and (procedure? xpr) 
             (condition-case (eq? (xpr type) type)
               ((exn) #f)))))))

(define (cell-of? ok?)
  (lambda (c%)
    (and (cell? c%) (ok? (c%)))))

(define-reader-ctor '% cell)
) ; module cells