java-like-object-system


Java uses a static object system (that is, class or objects can not be extended at runtime), and provides data hiding.

Inheritance is easy since Java does not do multiple inheritance. Thus, every object creates an internal object of the parent class, and passes unknown methods to that one.

What we don't implement, and some hints if you want to implement it:

 ;;; Java-style class definition syntax 
 (define-syntax define-java-class 
   (syntax-rules (METHOD) 
     ((DEFINE-JAVA-CLASS class-name () rest ...) 
      (DEFINE-JAVA-CLASS class-name (#F) rest ...)) 
     ((DEFINE-JAVA-CLASS class-name (parent-class) 
        ((var val) 
         ...) 
        (METHOD (method-name . method-args) 
          method-body1 method-body ...) 
        ...) 
      (DEFINE (class-name) 
        (LET ((PARENT-OBJECT (IF parent-class 
                                 (parent-class) 
                                 #F)) 
              (var val) 
              ...) 
          (DEFINE (method-name . method-args) 
            method-body1 method-body ...) 
          ... 
          (LAMBDA (METHOD-NAME) 
            (COND ((ASSQ METHOD-NAME 
                         `((method-name . ,method-name) ...)) 
                   => CDR) 
                  (ELSE 
                   (IF PARENT-OBJECT 
                       (PARENT-OBJECT METHOD-NAME) 
                       (ERROR "Unknown method" METHOD-NAME)))))))))) 
  
 ;;; Message sending 
 (define-syntax <- 
   (syntax-rules () 
     ((<- object method args ...) 
      ((object 'method) args ...)))) 
  
 ;; Object creation 
 (define (new class) 
   (class)) 

Now we can do the following:

 > (define-java-class <point> () 
     ((x 0) 
      (y 0)) 
     (method (get-x) 
       x) 
     (method (set-x! new-x) 
       (set! x new-x)) 
     (method (get-y) 
       y) 
     (method (set-y! new-y) 
       (set! y new-y))) 
 > (define p (new <point>)) 
 > (<- p get-x) 
 0 
 > (<- p set-x! 5) 
 > (<- p get-x) 
 5 
  
 ;;; Testing inheritance: 
  
 > (define-java-class <colored-point> (<point>) 
     ((color 'red)) 
     (method (get-color) 
       color) 
     (method (set-color! new-color) 
       (set! color new-color))) 
 > (define cp (new <colored-point>)) 
 > (<- cp get-color) 
 'red 
 > (<- cp get-x) 
 0 
 > (<- cp set-x! 5) 
 > (<- cp get-x) 
 5 

category-object-oriented