Program Description of Metaclasses

In this appendix the detailed program description of the metaclasses from section is shown.

(define (object-class-temporary)
  
  ;; class variables
  (let ((self nil)  ;; must be assigned to dispatch
        (super ())) ;; Super must refer to class, which in turn refers
                    ;; to object. Fixed via the method fix-super.
   
   ;; class variables
   (let () 
    
    ;; description of instances
     (define (instance-description-object)
       (let ((super ())
             (self nil))
         
         (define (set-self obj-part)
           (set! self obj-part))
         
         (define (responds-to operation)
           (let ((method (self operation))) 
             (if method #t #f)))
         
         (define (id)
           "I am an object instance")
         
         (define (class-of)
           outer-dispatch-object)
         
         (define (inner-dispatch-object op)
           (cond ((eq? op 'set-self!) set-self)
                 ((eq? op 'responds-to?) responds-to)
                 ((eq? op 'class) class-of)
                 ((eq? op 'id) id)
                 (else ())))
         
         (set! self inner-dispatch-object)
         self))
    
    
    ;; class methods
     
    (define (fix-super super-part)
      (set! super super-part)
      'done)
  
    (define (class-of)
      metaclass) 
     
    (define (id)
      "I am object")
     
    (define (set-self obj-part)
      (set! self obj-part)
      (send super 'set-self! obj-part))
    
    (define (outer-dispatch-object m)
      
      (cond ((eq? m 'instantiator) instance-description-object) 
            ((eq? m 'class) class-of)
            ((eq? m 'set-self!) set-self)
            ((eq? m 'id) id)
            ((eq? m 'fix-super) fix-super)
            (else (method-lookup super m))))
     
    (set! self outer-dispatch-object)
    
    self)))





 
(define (metaclass-class)
  
  ;; class variables
  (let ((self nil)  
        (super (new-instance-part object))) 
   
   ;; class variables
   (let () 
    
    ;; METACLASS DOES NOT HAVE AN INSTANCE DESCRIPTION
    
    ;; class methods
    
    (define (class-of)
      self)  ;; the circularity of the is-a relation.
     
    (define (id)
      "I am metaclass")
     
    (define (set-self object-part)
      (set! self object-part)
      (send super 'set-self! object-part))
    
    (define (outer-dispatch-metaclass m)
      
      (cond ((eq? m 'class) class-of)
            ((eq? m 'set-self!) set-self)
            ((eq? m 'id) id)
            (else (method-lookup super m))))
     
    (set! self outer-dispatch-metaclass)
    self)))






(define (class-class)
  
  ;; class variables
  (let ((self nil)  
        (super (new-instance-part object)))  
   
   ;; class variables
   (let ((instances ())) 
    
    ;; THERE IS NO INSTANCE-DESCRIPTION OF THIS CLASS.
    
    ;; class methods
     
    (define (new)
      (let* ((instance
               (new-instance
                 (method-lookup self 'instantiator))))
        (set! instances (cons instance instances))
        instance))
     
    (define (number-of-instances)
      (length instances))
    
    (define (class-of)
      metaclass) 
     
    (define (id)
      "I am class")
     
    (define (set-self object-part)
      (set! self object-part)
      (send super 'set-self! object-part))
    
    (define (outer-dispatch-class m)
      
      (cond ((eq? m 'new) new)
            ((eq? m 'class) class-of)
            ((eq? m 'set-self!) set-self)
            ((eq? m 'id) id)
            ((eq? m 'instances) number-of-instances)
            (else (method-lookup super m))))
     
    (set! self outer-dispatch-class)
    self)))



(define object (new-part object-class-temporary)) 
(send object 'fix-super (new-part class-class))
(virtual-operations object)


(define metaclass (new-instance metaclass-class)) 

(define (object-class)
  ;; return an object class, where the super is fixed.
  (let ((oc (new-part object-class-temporary)))
    (send oc 'fix-super (new-part class-class))
    oc))