;; FILE          "yasos.scm"
;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
;; AUTHOR        Ken [dot] Dickey [at] Whidbey [dot] Com
;; DATE          1992 March 1
;; LAST UPDATED  1992 March 5
;; CHICKEN-PORT  2008 February 7

;; REQUIRES  R4RS Syntax System

;; NOTES: An object system for Scheme based on the paper by
;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
;; Scheme", Proceedings of the 1988 ACM Conference on LISP and 
;; Functional Programming, July 1988 [ACM #552880].

;;
;; INTERFACE:
;;
;; (DEFINE-OPERATION (opname self arg ...) default-body)
;;
;; (DEFINE-PREDICATE opname)
;;
;; (OBJECT ((name self arg ...) body) ... )
;;
;; (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...)
;;
;; in an operation {a.k.a. send-to-super}
;;   (OPERATE-AS component operation self arg ...)
;;
(module yasos
  (export define-operation define-predicate object object-with-ancestors operate-as
	  make-instance instance? instance-dispatcher)
  (import scheme chicken)

  (define make-instance 'bogus)  ;; defined below
  (define instance?     'bogus)
  (define instance-dispatcher 'bogus)
  
  (let ((instance-tag "instance"))
        ;; Make a unique tag within a local scope.
        ;; No other data object is EQ? to this tag.
    (set! make-instance
    (lambda (dispatcher) (cons instance-tag dispatcher)))
    (set! instance?
	  (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
    (set! instance-dispatcher
	  (lambda (inst) (cdr inst))))
      
;;;
;;; COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
;;;
;;;Permission is hereby granted, free of charge, to any person
;;;obtaining a copy of this software and associated documentation
;;;files (the "Software"), to deal in the Software without
;;;restriction, including without limitation the rights to use,
;;;copy, modify, merge, publish, distribute, sublicense, and/or
;;;sell copies of the Software, and to permit persons to whom
;;;the Software is furnished to do so, subject to the following
;;;conditions:
;;;
;;;The above copyright notice and this permission notice shall
;;;be included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;OTHER DEALINGS IN THE SOFTWARE.




;; DEFINE-OPERATION

(define-syntax define-operation
  (syntax-rules ()
    ((_ (<name> <inst> <arg> ...) <exp1> <exp2> ...) ;; with body
     (define <name>
       (letrec ((self
                  (lambda (<inst> <arg> ...)
                    (cond
                      ((and (instance? <inst>) 
                            ((instance-dispatcher <inst>) self))
                         => (lambda (operation) (operation <inst> <arg> ...)))
                      (else <exp1> <exp2> ...)))))
         self)))
    ((_ (<name> <inst> <arg> ...)) ;; no body
     (define-operation (<name> <inst> <arg> ...)
       (error "Operation not handled" '<name>
              (format #f (if (instance? <inst>) "#<INSTANCE>" "~s") <inst>))))))


;; DEFINE-PREDICATE

(define-syntax define-predicate
  (syntax-rules ()
    ((_ <name>)
     (define-operation (<name> obj) #f))))


;; OBJECT

(define-syntax object
  (syntax-rules ()
    ((_ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
     (let ((table
             (list (cons <name>
                   (lambda (<self> <arg> ...) <exp1> <exp2> ...)) ...)))
       (make-instance
         (lambda (op)
           (cond ((assq op table) => cdr)
                 (else #f))))))))


;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}

(define-syntax object-with-ancestors
  (syntax-rules ()
    ((_ ((<ancestor1> <init1>) ...) <operation> ...)
     (let ((<ancestor1> <init1>) ... )
       (let ((child (object <operation> ...)))
         (make-instance
           (lambda (op) 
             (or ((instance-dispatcher child) op)
                 ((instance-dispatcher <ancestor1>) op) ...))))))))


;; OPERATE-AS  {a.k.a. send-to-super}

; used in operations/methods

(define-syntax operate-as
  (syntax-rules ()
    ((_ <component> <op> <composit> <arg> ...)
     (((instance-dispatcher <component>) <op>) <composit> <arg> ...)))) )


;;;
;;; COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
;;;
;;;Permission is hereby granted, free of charge, to any person
;;;obtaining a copy of this software and associated documentation
;;;files (the "Software"), to deal in the Software without
;;;restriction, including without limitation the rights to use,
;;;copy, modify, merge, publish, distribute, sublicense, and/or
;;;sell copies of the Software, and to permit persons to whom
;;;the Software is furnished to do so, subject to the following
;;;conditions:
;;;
;;;The above copyright notice and this permission notice shall
;;;be included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;OTHER DEALINGS IN THE SOFTWARE.