Incomplete process of object system implementation on top of scheme lambdas

lambdaobj.scm

#lang scheme

;;; lambda-dictionary
;;;
(define (make-dict pairs)
  (define (pair-key p) (car p))
  (define (find key pairs)
    (define (target? p)
      (equal? key (pair-key p)))
    ;;
    (cond ((null?   pairs)       '())
          ((target? (car pairs)) (car pairs))
          (else 
           (find key (cdr pairs)))))
  ;;
  (lambda (key) (find key pairs)))

(display "Dict test\n")

(define d 
  (make-dict `((foo . bar) 
               (ban . ,(lambda (x) (+ 1 x))))))
(d 'foo)
((cdr (d 'ban)) 0)

;;; simple object
;;;
(define (make-dispatcher obj)
  (lambda (key . args) 
    (apply (cdr (obj key)) args)))

(define (rational n d) 
  (define methods 
    `((numer . ,(lambda () n))
      (denum . ,(lambda () d))
      (add   . ,(lambda (other)
                (define num 
                  (+ (* n (other 'denum)) 
                     (* d (other 'numer))))
                (define den 
                  (* d (other 'denum)))
                (rational num den)))))
  (define obj (make-dict methods))
  (make-dispatcher obj))

(display "Simple object test\n")

(((rational 1 2) 'add (rational 3 2)) 'denum)

;;; inheritance and almost-dyn-dispatch
;;;
(define (make-dispatcher-ex obj . optional-arg)
  (define (impl p) (cdr p))
  (define (get-parent-disp) (car optional-arg))
  (lambda (key . args) 
    (define binding (obj key))
    (define unbound? (null? binding))
    (cond (unbound? (apply (get-parent-disp) (cons key args)))
          (else     (apply (impl binding)    args)))))

(define (parent a)
  (define methods
    `((foo . ,(lambda (b) (+ a b)))
      (bar . ,(lambda () "Hello!"))))
  (make-dispatcher-ex (make-dict methods)))

(define (child z)
  (define methods
    `((bar . ,(lambda () "Bye!"))))
  (make-dispatcher-ex (make-dict methods) (parent (- z 1))))

(display "Inherit. test\n")

(define p (parent 1))
(define c (child 10))
(p 'bar)
(p 'foo 10)
(c 'bar)
(c 'foo 5)

;;; self-correct dyn-dispatch
;;;
(define (chain-dicts d1 d2) 
  (lambda (key) 
         (define res1 (d1 key))
         (cond ((null? res1) (d2 key))
               (else res1))))

(define (make-dispatcher-self dt)
  (define (impl p) (cdr p))
  (define (prepend-self args)
    (cons (make-dispatcher-self dt) args))
  (lambda opt-args
    (define (get-key)  (car opt-args))
    (define (get-args) (cdr opt-args))
    (cond ((null? opt-args) dt)
          (else 
           (apply (impl (dt (get-key))) 
                  (prepend-self (get-args)))))))

(define (extract-dispatch-table obj) (obj))
(define (extends dt obj) 
  (chain-dicts dt (extract-dispatch-table obj)))

(define (s-parent a)
  (define methods
    `((foo . ,(lambda (self b) (+ a b)))
      (bar . ,(lambda (self x1 x2) (self 'foo (+ x1 x2))))
      (a   . ,(lambda (self) a))))
  (make-dispatcher-self (make-dict methods)))

(define (s-child a)
  (define methods
    `((foo . ,(lambda (self b) (* a b)))))
  (make-dispatcher-self (extends (make-dict methods) 
                                 (s-parent (- a)))))

(display "Dyn-disp test\n")

(define sp (s-parent 1))
(define sc (s-child  2))
(sp 'foo 10)
(sp 'bar 10 12)
(sp 'a)
(sc 'foo 10)
(sc 'bar 10 12)
(sc 'a)

;;; Macro-syntax

;(define-syntax class
;  (syntax-rules (extends rmethods method)
;    ((_ rmethods () r) `r)
;    ((_ rmethods ((method (name arg1 ...) body ...) . methods) r)
;     (class rmethods methods ((name . ,(lambda (self arg1 ...) body ...)) . r)))
;    ((_ header (extends parent) body ...)
;     (define header
;       (define methods (class rmethods (body ...) ()))
;       (make-dispatcher-self (extends (make-dict methods) parent))))
;    ((_ header body ...)
;     (define header 
;       (define methods (class rmethods (body ...) ()))
;       (make-dispatcher-self (make-dict methods))))))

;(class (my-class x1 x2) 
;       (extends my-other-class)
;  (read 'x1)
;  (read-write 'x2)
;  (method (my-method a) (+ a (self x2)))
;  (x2 () x2))
  
;(class (my-class x1 x2) 
;  (method (my-method a) (+ a (self 'x2)))
;  (method (x2)          x2))

;(class rmethods
;  ((method (my-method a) (+ a (self 'x2)))
;  (method (x2)          x2)) ())