yasos-r7rs/yasos.sld

(define-library (yasos)
  (import (scheme base))
  (export define-operation define-predicate
          object object-with-ancestors operate-as)
  (begin
    (define-record-type <yasos-object>
      (make-instance dispatcher)
      instance?
      (dispatcher instance-dispatcher))

    ;; DEFINE-OPERATION

    (define-syntax define-operation
      (syntax-rules ()
        ((_ (name inst arg ...) xpr . xprs) ; ordinary argument list
         (define name
           (letrec ((self
                     (lambda (inst arg ...)
                       (cond
                        ((and (instance? inst) 
                              ((instance-dispatcher inst) self))
                         => (lambda (operation) (operation inst arg ...)))
                        (else xpr . xprs)))))
             self)))
        ((_ (name inst . args) xpr . xprs) ; dotted argument list
         (define name
           (letrec ((self
                     (lambda (inst . args)
                       (cond
                        ((and (instance? inst) 
                              ((instance-dispatcher inst) self))
                         => (lambda (operation)
                              (apply operation inst args)))
                        (else xpr . xprs)))))
             self)))
        ((_ (name inst . args)) ;; no body
         (define-operation (name inst . args)
           (error "Operation not handled" 'name inst)))))

    ;; DEFINE-PREDICATE

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

    ;; OBJECT

    (define-syntax object
      (syntax-rules ()
        ((_ ((name inst . args) xpr . xprs) ...)
         (let ((table
                (list (cons name
                            (lambda (inst . args) xpr . xprs)) ...)))
           (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> ...))))))