;;;"yasyn.scm" YASOS in terms of "object.scm"
;;; Author: Wade Humeniuk <humeniuw@cadvision.com>
;;;
;;; This code is in the public domain.

(require 'object)
(require 'object->string)

;; (define yasos:make-instance 'bogus)
(define yasos:instance?     object?)

(define (pormat dest arg)
  (define obj (if (yasos:instance? arg) "#<INSTANCE>" arg))
  (cond ((eqv? dest #t) (display obj))
	(dest (display obj dest))
	((yasos:instance? arg) obj)
	(else (object->string arg))))

;@
(define add-setter	'bogus)
(define remove-setter-for 'bogus)
;@
(define setter
  (let ( (known-setters (list (cons car set-car!)
			      (cons cdr set-cdr!)
			      (cons vector-ref vector-set!)
			      (cons string-ref string-set!))
	 )
	 (added-setters '())
       )

    (set! add-setter
      (lambda (getter setter)
	(set! added-setters (cons (cons getter setter) added-setters)))
    )
    (set! remove-setter-for
      (lambda (getter)
	(cond
	  ((null? added-setters)
	   (slib:error 'remove-setter-for 'unknown-getter getter)
	  )
	  ((eq? getter (caar added-setters))
	   (set! added-setters (cdr added-setters))
	  )
	  (else
	    (let loop ((x added-setters) (y (cdr added-setters)))
	      (cond
		((null? y) (slib:error 'remove-setter-for 'unknown-getter
				       getter))
		((eq? getter (caar y)) (set-cdr! x (cdr y)))
		(else (loop (cdr x) (cdr y)))
	  ) ) )
     ) ) )

    (letrec ( (self
		 (lambda (proc-or-operation)
		   (cond ((assq proc-or-operation known-setters) => cdr)
			 ((assq proc-or-operation added-setters) => cdr)
			 (else (proc-or-operation self))) )
	    ) )
      self)
) )

(define (yasos:make-access-operation <name>)
  (letrec ( (setter-dispatch
	       (lambda (inst . args)
		   (cond
		     ((and (yasos:instance? inst)
			   (get-method inst setter-dispatch))
		       => (lambda (method) (apply method (cons inst args)))
		     )
		     (else #f)))
	    )
	    (self
	       (lambda (inst . args)
		  (cond
		     ((eq? inst yasos:setter) setter-dispatch) ; for (setter self)
		     ((and (yasos:instance? inst)
			   (get-method inst self))
		      => (lambda (method) (apply method (cons inst args)))
		     )
		     (else (slib:error 'operation-not-handled <name> inst))
		)  )
	    )
	  )

	  self
) )

;;---------------------
;; general operations
;;---------------------

;;; if an instance does not have a PRINT operation..

;;(define-operation (yasos:print obj port) (pormat port obj) )
;@
(define print
  (make-generic-method
   (lambda (obj!2 port!2)
     (pormat port!2 obj!2))))

;;; default behavior

;;(define-operation (yasos:size obj)
;;  (cond ((vector? obj) (vector-length obj))
;;        ((list?   obj) (length obj))
;;        ((pair?   obj) 2)
;;        ((string? obj) (string-length obj))
;;        ((char?   obj) 1)
;;        (else (slib:error "Operation not supported: size" obj))))
;@
(define size
  (make-generic-method
   (lambda (obj!2)
     (cond ((vector? obj!2) (vector-length obj!2))
	   ((list? obj!2) (length obj!2))
	   ((pair? obj!2) 2)
	   ((string? obj!2) (string-length obj!2))
	   ((char? obj!2) 1)
	   (else (slib:error 'size "Operation not supported" obj!2))))))

;;; internal aliases:
;;(define yasos:size size)
(define yasos:setter setter)

;; (define-syntax YASOS:INSTANCE-DISPATCHER
;;   ;; alias so compiler can inline for speed
;;   (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst))))

;; DEFINE-OPERATION
;@
(define-syntax define-operation
  (syntax-rules ()
    ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
     ;;=>
     (define <name> (make-generic-method
		     (lambda (<inst> <arg> ...) <exp1> <exp2> ...))))

    ((define-operation (<name> <inst> <arg> ...) ) ;; no body
     ;;=>
     (define-operation (<name> <inst> <arg> ...)
       (slib:error 'operation-not-handled
		   '<name>
		   (if (yasos:instance? <inst>) "#<INSTANCE>" <inst>))))))

;; DEFINE-PREDICATE
;@
(define-syntax define-predicate
  (syntax-rules ()
    ((define-predicate <name>)
     ;;=>
     (define <name> (make-generic-predicate)))))

;; OBJECT
;@
(define-syntax object
  (syntax-rules ()
    ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
    ;;=>
     (let ((self (make-object)))
       (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
       ...
       self))))

;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
;@
(define-syntax object-with-ancestors
  (syntax-rules ()
    ((object-with-ancestors ( (<ancestor1> <init1>) ... )
			    ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
    ;;=>
     (let* ((<ancestor1> <init1>)
	    ...
	    (self (make-object <ancestor1> ...)))
       (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
       ...
       self))))

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

; used in operations/methods
;@
(define-syntax operate-as
  (syntax-rules ()
   ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ???
   ;;=>
    ((get-method <component> <op>) <composit> <arg> ...))))



;; SET & SETTER

;@
(define-syntax set
  (syntax-rules ()
    ((set (<access> <index> ...) <newval>)
     ((yasos:setter <access>) <index> ... <newval>)
    )
    ((set <var> <newval>)
     (set! <var> <newval>)
    )
) )
;@
(define-syntax define-access-operation
  (syntax-rules ()
    ((define-access-operation <name>)
     ;=>
     (define <name> (yasos:make-access-operation '<name>))
) ) )