;; FILE		"oop.scm"
;; IMPLEMENTS	YASOS: Yet Another Scheme Object System
;; AUTHOR	Kenneth Dickey
;; DATE		1992 March 1
;; LAST UPDATED	1992 March 5

;; 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 ...)
;;


;; INSTANCES

; (define-predicate instance?)
; (define (make-instance dispatcher)
;    (object
; 	((instance?  self) #t)
;       ((instance-dispatcher self) dispatcher)
; )  )

(define make-instance 'bogus)  ;; defined below
(define instance?     'bogus)
(define-syntax INSTANCE-DISPATCHER  ;; alias so compiler can inline for speed
   (syntax-rules () ((instance-dispatcher inst) (cdr inst)))
)

(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))))
)

;; DEFINE-OPERATION

(define-syntax DEFINE-OPERATION
  (syntax-rules ()
    ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
     ;;=>
     (define <name>
       (letrec ( (self
                  (lambda (<inst> <arg> ...)
		   (cond
		     ((and (instance? <inst>) 
		           ((instance-dispatcher <inst>) self))
		      => (lambda (operation) (operation <inst> <arg> ...))
                     )
		     (else <exp1> <exp2> ...)
            ) ) )  )
        self)
  ))
  ((define-operation (<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 ()
    ((define-predicate <name>)
     ;;=>
     (define-operation (<name> obj) #f)
    )
) )


;; OBJECT

(define-syntax OBJECT
  (syntax-rules ()
    ((object ((<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 ()
    ((object-with-ancestors ( (<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 ()
   ((operate-as <component> <op> <composit> <arg> ...)
   ;;=>
    (((instance-dispatcher <component>) <op>) <composit> <arg> ...)
  ))
)


;;			--- End YASOS ---
