Program (original) (raw)

(define (new-instance class . parameters) (let ((instance (apply class parameters))) (virtual-operations instance) instance))

; Arrange for virtual operations in object (define (virtual-operations object) (send 'set-self! object object))

(define (new-part class . parameters) (apply class parameters))

(define (method-lookup object selector) (cond ((procedure? object) (object selector)) (else (error "Inappropriate object in method-lookup: " object))))

(define (send message object . args) (let ((method (method-lookup object message))) (cond ((procedure? method) (apply method args)) ((null? method) (error "Message not understood: " message)) (else (error "Inappropriate result of method lookup: " method)))))

; The root in the class hierarchy (define (object) (let ((super '()) (self 'nil))

(define (set-self! object-part) (set! self object-part))

(define (dispatch message) (cond ((eqv? message 'set-self!) set-self!) (else (error "Undefined message" message))))

(set! self dispatch) self))

; The class y which inherits from x and redefines get-tate (define (x) (let ((super (new-part object)) (self 'nil))

(let ((x-state 1) )

 (define (get-state) x-state)

 (define (res)
   (send 'get-state self))

 (define (set-self! object-part)
     (set! self object-part)
     (send 'set-self! super object-part))
 
 (define (self message)
     (cond ((eqv? message 'get-state) get-state)
           ((eqv? message 'res) res)
           ((eqv? message 'set-self!) set-self!)
           (else (method-lookup super message))))
 
  self)))  ; end x

(define (y) (let ((super (new-part x)) (self 'nil))

(let ((y-state 2) )

 (define (get-state) y-state)

 (define (set-self! object-part)
     (set! self object-part)
     (send 'set-self! super object-part))
 
 (define (self message)
     (cond ((eqv? message 'get-state) get-state)
           ((eqv? message 'set-self!) set-self!)
           (else (method-lookup super message))))
 
  self))) ; end y