; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2017-2018, 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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.


#|[
In their paper "The First Report on Scheme Revisited", the authors
Sussman and Steele remarked

"We also now believe that Carl Hewitt was right: we would have been
better off to have introduced cells as a separate, primitive kind of
object, rather than allowing assignment to any and every lambda-bound
variable."

This module implements a cell datatype. Using it instead of set!
set-car! and set-cdr! you have what Hewitt proposed ...
]|#

;(require-library simple-exceptions)

(module simple-cells (simple-cells cell cell? cell-of?)
  (import scheme
          (only simple-exceptions <<<)
          (only (chicken condition) condition-case)
          (only (chicken base)
                define-values gensym case-lambda error print))

;;; (cell var . tests)
;;; (cell? xpr)
;;; ------------------
;;; cell constructor and type predicate
(define-values (cell cell?)
  (let ((type (gensym 'cell)))
    (values
      (lambda (var . tests)
        (let ((checks #f) (state #f))
          (set! checks tests)
          (set! state (apply (<<< 'cell) var 'state checks))
          (case-lambda
            (() state);(values state checks))
            ((arg)
             (let ((old state))
               (set! state
                     (if (and (symbol? arg) (eq? arg type))
                       arg
                       (apply (<<< 'cell) arg 'arg checks)))
               old)))))
      (lambda (xpr)
        (and (procedure? xpr)
             (let ((old (xpr)) ; save state
                   (result? (condition-case
                              (eq? type
                                   (and (xpr type) (xpr)))
                              ((exn) #f))))
               (xpr old) ; restore state
               result?))))))

;;; ((cell-of? ok? ...) xpr)
;;; ------------------------
;;; evaluates xpr to a cell passing the ok? ... checks?
(define ((cell-of? . predicates) xpr)
  (and (cell? xpr)
       (let loop ((preds predicates))
         (cond
           ((null? preds) #t)
           (((car preds) (xpr))
            (loop (cdr preds)))
           (else #f)))))

;;; (simple-cells sym ..)
;;; ---------------------
;;; documentation procedure
(define simple-cells
  (let ((als '(
    (simple-cells
      procedure:
      (simple-cells sym ..)
      "documentation procedure")
    (cell
      procedure:
      (cell var . tests)
      "creates a cell, initialising its contents to var"
      "provided all test predicates succed."
      "A cell is a procedure of zero or one argument."
      "Without argument, it returns two values,"
      "its content and the list of test predicates."
      "With an argument the content is changed to that argument"
      "provided all test predicates succeed.")
    (cell?
      procedure:
      (cell? xpr)
      "type predicate.")
    (cell-of?
      procedure:
      (cell-of? . predicates)
      "returns a predicate, which checks, if its argument"
      "is passed by any predicate of the predicates list")
    )))
    (case-lambda
      (()
       (map car als))
      ((sym)
       (let ((pair (assq sym als)))
         (if pair
           (for-each print (cdr pair))
           (error "Not in list"
                  sym
                  (map car als))))))))

) ; module simple-cells