OOP in Scheme

[Brian of ASTD-CP <brian@jade.berkeley.edu>]

; methods2.scm
;
; ===============================================================
; Brian Beckman                  |    brian@topaz.jpl.nasa.gov
; Mail Stop 510-202              |    (818) 397-9207
; Jet Propulsion Laboratory      | 
; Pasadena, CA 91109             |    30 June 1989
; ===============================================================

; INTRODUCTION
;
; This is a tiny object-oriented programming system with multiple
; inheritance and error handling.  It is modeled after the message
; passing modules in Chapter 3 of Abelson & Sussman.  It is 
; implemented in ``pure'' Scheme, without macros or syntax
; extensions.
; 
; This programming system is implemented as a technique, or
; programming convention, with some helper routines.  The programming
; convention is not enforced, as we choose to avoid syntax-extensions
; for portability's sake.  The technique is illustrated in this file
; with a few examples.  In example one, a parent class, named
; ``parent,'' passes its attributes to a child named ``child.''  In
; example two, two parents, ``mother'' ``fater'', pass their attributes
; to a child class, ``daughter.''  The reader will perceive the technique
; by generalization from these examples and will be able to apply it
; to his or her own problems.
; 
; Every class is represented by its constructor procedure.  This
; procedure returns a message dispatching procedure.  The message
; dispatching procedure should be named ``self'' so that an object can
; conveniently send messages to itself.  However, ``self'' is an
; internal name not known outside the constructor.  
; 
; In summary, classes are represented by constructor procedures, and
; objects, or instances of classes, are represented by message
; dispatching procedures.  The present version of ``methods'' does not
; support code sharing, so every instance of a class has its own
; private copies of the method code.  We expect to implement code
; sharing in a later version of ``methods''.
; 
; The message dispatching procedure walks the multiple inheritance
; hierarchy upwards until it finds an object that can understand a
; message, starting with itself.  If no object that can understand the
; message is found, a global error procedure is called.
; 
; IMPLEMENTATION
;
; Error processing is challenging.  We should like to have two modes.
; In ``normal mode'', an error is reported only by the first receiver
; of a message.  In ``debug mode'', an inheritance traceback should be
; given whereby every object in an inheritance hierarchy will report
; when it fails to recognize a given message.  The following variable
; represents that mode.  (For simplicity, this object is hidden only
; by its name, which is unusual enough that it is unlikely to be
; trammeled by an application.  This is not the recommended technique
; for data hiding.  Data hiding ought to be implemented through the
; techniques shown in this file!  However, since this error handling
; part of the methods package is considered system programming,
; certain liberties in style are justifiable.  There are in fact, good
; technical reasons for the error handling code to be implemented with
; global variables, which the perceptive reader will be able to
; deduce.)

(define **method-mode** 'normal-method-mode)

; The user can set these modes as follows.

(define (set-debug-method-mode)
  (set! **method-mode** 'debug-method-mode))

(define (set-normal-method-mode)
  (set! **method-mode** 'normal-method-mode))

(define (reset-debug-method-mode)  ;;; synonym
  (set! **method-mode** 'normal-method-mode))

; and test them with the following routine:

(define (test-debug-method-mode)
  (eq? **method-mode** 'debug-method-mode))

; Before presenting the examples of classes and objects, some helper
; routines are needed.
;
; When an object cannot recognize a message, and none of its ancestor
; objects can recognize it, the object creates an error procedure and
; returns it as the result of the message dispatcher.  

(define **method-error-class-name** "No class name.")

(define **method-error-message** 'no-message)

(define (error-method . junk-args)
  (display **method-error-class-name**)
  (display ": uknown message: '")
  (display **method-error-message**)
  (newline)
  ())

(define (make-error-method class-name msg)
  (set! **method-error-class-name** class-name)
  (set! **method-error-message** msg)
  error-method)

; The procedure that walks the inheritance hierarchy must cooperate
; in the error handling.  

(define (search-supertypes supers msg)
  (define method ())
  (if (test-debug-method-mode)
      (begin
       (display "Searching...")
       (newline)))
  (cond
   (  (null? supers)  ()  )
   (  (begin
       (set! method ((car supers) msg))
       (eq? method error-method))
                      (if (test-debug-method-mode)
                          (error-method))
                      (search-supertypes (cdr supers) msg)  )
   (  else  method  )))

; This procedure implements the inheritance of methods.  It is greatly
; complicated by proper error handling.  Without error handling, the
; routine would resemble the following, which is much easier to
; understand (without error handling, the programming convention is
; that an object that does not understand a message returns the
; unexecutable method ``()'').
;
; (define (search-supertypes supers msg)
;   (cond
;     (  (null? supers)  ()  )
;     (  ((car supers) msg)  )
;     (  else  (search-supertypes (cdr supers) msg)  )))
;
; The actual routine, with proper error handling, works as follows.  A
; local variable, ``method'', is defined.  Its value is not important
; to begin with.  If debugging is on, we print a message telling the
; user that the inheritance hierarchy is being searched.  Then, the
; list of supertypes is investigated.  If the list is empty, we return
; nil, which signals the caller to create and return the error-method,
; as we shall see in the examples later.  If the list is not empty, we
; pass the message to the first supertype in the list.  The return
; value is assigned to the local variable ``method''.  If the returned
; method is the one and only global error-method, then the supertype,
; and, recursively, all its supertypes, did not know the message.  
; If debugging is on, we execute the returned error-method, contributing
; to the aforementioned inheritance traceback.  Finally, we return 
; the value of a recursive call of search-supertypes on the remainder 
; of the list of supertypes.  If the returned method is not the 
; error-method, then the supertype did understand the message after 
; all somewhere in the hierarchy, and the returned method is the
; return value of this procedure.
;
; Note that the list of supertypes is searched in order from front
; to back.  The first match of a message results in the successful
; finding of a method.  The order of supertypes in the list is 
; significant only when more than one supertype can understand
; a given message.  The earlier members of the list will shadow
; the later ones.  In some object-oriented programming systems, one
; refers to the ``overriding'' of methods.  The shadowing in 
; ``methods'' is our form of method overriding, and it is under
; explicit control of the programmer who sets the order of supertypes
; in the list of supertypes.  
; 
; In summary, search-supertypes passes the message to the ancestors,
; in pre-order, returning the first method found.  
;
; The next helper routine passes a message, and a variable number of
; arguments, to all the parents of an object.  For side effects, it
; executes any methods found.  Parents are defined as 
; first level ancestors.

(define (for-all-parents supers msg . args)
  (let (  (method-list
           (map (lambda (supertype) (supertype msg)) supers))
          (for-proc
           (lambda (method) (apply method args)))  )
    (for-each for-proc method-list)))

; With the current programming convention, it is not possible to pass
; a message to all ancestors and execute the methods for side-effect
; without explicit cooperation on the part of the objects involved. In
; other words, the procedure ``for-all-ancestors'', analogous to
; ``for-all-parents'', cannot be implemented in the current version of
; the methods package.  The reason is that the convention calls for
; every class to call ``search-supertypes'', which stops when it finds
; a method.  The convention would have to be augmented so that objects
; would call ``find-all-methods'' (defined below) on an appropriate
; message.  Since we expect the need for ``for-all-ancestors'' to be
; fairly rare, the necessary changes to the methods package will be
; reserved for a future version.

(define (find-all-methods supers msg)
  (cond
   (  (null? supers)  ()  )
   (  else  (cons ((car supers) msg)
                  (find-all-methods (cdr supers) msg))  )))

; EXAMPLES (cut here to end of file to throw examples away)
;
; Our first example class, or object type, is ``parent'', represented
; by the following constructor procedure.

(define (new-parent arg)
  (let ((state-var (* arg arg))
        (supers ()))
    
    (define (report-state-var)
      (display state-var)
      (newline)
      state-var)
    
    (define (update-state-var arg)
      (set! state-var (* arg arg)))
    
    (define (echo arg)
      (display arg) (newline))
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)  report-state-var  )
       (  (eq? msg 'update)  update-state-var  )
       (  (eq? msg 'echo)    echo  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Parent" msg)  )))
    
    self))

; This class, or constructor procedure, completely illustrates, by
; example, the programming convention of the ``methods'' technique.  
; The constructor takes a single argument, whose square it stores in a
; local state variable.  Another state variable, the list of
; supertypes, is set to nil, since this class is at the root of an
; inheritance hierarchy.  Three methods are defined, one that reports
; and returns the current value of the state variable, one that sets
; the state variable equal to a new square, and one that merely echoes
; its argument.  A method dispatching procedure, conventionally named
; ``self'', tests a given message against three symbols and returns
; the corresponding method if a match is found.  If no match is found,
; the list of supertypes is searched for a match.  In the case of this
; class, ``parent'', the search is purely formal, to illustrate how it
; should be done, since ``parent'' has no ancestors.  However, if a
; match were found among the list of supertypes, the method would be
; returned.  Note how the search relys on the fact that any non-nil
; result is treated as a successful ``cond'' clause, terminating the
; ``cond'' statement. Search-supertypes returns nil only when a match
; is not found.  Finally, if no match is found locally or among the
; supertypes, an appropriate error-method is pseudo-created and
; returned.
; 
; We now test this class by making an instance and passing it
; messages.

(define p (new-parent 42))

((p 'report))

((p 'update) 69)

((p 'report))

((p 'echo) (list 1 2 3))

; We test error handling:

((p 'bogus))

(set-debug-method-mode)

((p 'bogus))

(reset-debug-method-mode)

((p 'bogus) 'here 'are 'some 'junk 'arguments)

; Continuing this example, let us define a child class inheriting
; all attributes and methods of the parent.  Note the attributes of
; the parent are only accessible through the parent's method
; discipline.  This is a strict form of inheritance, and the default
; in C++, for example.  (C++ allows the programmer to override 
; ancestors' access discipline, at his own peril.)

(define (new-child arg1 arg2)
  
  (let* (  (leg1 (* arg1 arg1))
           (leg2 (* arg2 arg2))
           (hypotenuse (+ leg1 leg2))
           (supers (list
                    (new-parent hypotenuse)))  )
    
    (define (report)
      (for-all-parents supers 'report)
      (display "Leg1 = ") (display (sqrt leg1)) (newline)
      (display "Leg2 = ") (display (sqrt leg2)) (newline)
      (display "Hypo = ") (display (sqrt hypotenuse)) (newline))
    
    (define (update-leg1 val)
      (set! leg1 (* val val))
      (set! hypotenuse (+ leg1 leg2)))
    
    (define (update-leg2 val)
      (set! leg2 (* val val))
      (set! hypotenuse (+ leg1 leg2)))
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)       report       )
       (  (eq? msg 'update-leg1)  update-leg1  )
       (  (eq? msg 'update-leg2)  update-leg2  )
       (  (search-supertypes supers msg)       )
       (  else  (make-error-method "Child" msg)       )))
    
    self))

; We now test the child type.

(define c (new-child 3 4))

((c 'report))  ;;; passes message to all parents

((c 'update-leg1) 5)

((c 'update-leg2) 12)

((c 'report))

((c 'echo) '(foo bar))   ;;; msg known only in the parent

((c 'bogus) 'baz 'rat)

(set-debug-method-mode)

((c 'bogus) 'baz 'rat)

(reset-debug-method-mode)

((c 'bogus) 'baz 'rat)

; The last example, presented without detailed narrative, shows a 
; slightly deeper inheritance hierarchy.  The leaf is a type named
; ``daughter''.  Its two parent classes are ``mother'' and ``father''.  
; In turn, every mother has an ``estate'' and a ``religion'' (please
; excuse the somewhat strained metaphor of inheritance; this is just
; a little example).  

(define (new-estate value)
  (let ((value value)
        (supers ()))
    
    (define (report)
      (display "Estate = $") (display value) (newline))
    
    (define (what-value) value)
    
    (define (increase amount) (set! value (+ value amount)))
    
    (define (decrease amount) (set! value (- value amount)))
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)       report  )
       (  (eq? msg 'what-estate)  what-value  )
       (  (eq? msg 'increase)     increase  )
       (  (eq? msg 'decrease)     decrease  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Estate" msg)  )))
    
    self))

(define (new-religion theReligion)
  (let ((religion theReligion)
        (supers ()))
    
    (define (report) (display "Religion = ") (display religion) (newline))
    
    (define (what-religion) religion)
    
    (define (convert theNewReligion) (set! religion theNewReligion))
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)         report  )
       (  (eq? msg 'convert)        convert  )
       (  (eq? msg 'what-religion)  what-religion  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Religion" msg)  )))
    
    self))

(define (new-father eye-color)
  (let ((eye-color eye-color)
        (supers ()))
    
    (define (report) (display "Father's eye color = ")
      (display eye-color) (newline))
    
    (define (what-eye-color) eye-color)
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)          report  )
       (  (eq? msg 'what-eye-color)  what-eye-color  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Father" msg)  )))
    
    self))

(define (new-mother eye-color estate religion)
  (let ((eye-color eye-color)
        (supers (list
                 (new-estate estate)
                 (new-religion religion))))
    
    (define (report)
      (for-all-parents supers 'report)
      (display "Mother's eye color = ")
      (display eye-color) (newline))
    
    (define (what-eye-color) eye-color)
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)          report  )
       (  (eq? msg 'what-eye-color)  what-eye-color  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Mother" msg)  )))
    
    self))

(define (new-daughter eye-color)
  (let* ((eye-color eye-color)
         (parents-eye-color
          (if (eq? eye-color 'blue)  'blue  'brown))
         (supers (list
                  (new-father parents-eye-color)
                  (new-mother parents-eye-color 500000 'Jewish))))
    
    (define (report)
      (for-all-parents supers 'report)
      (display "Daughter's eye color = ")
      (display eye-color)
      (newline))
    
    (define (what-eye-color) eye-color)
    
    (define (self msg)
      (cond
       (  (eq? msg 'report)          report  )
       (  (eq? msg 'what-eye-color)  what-eye-color  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Daughter" msg)  )))
    
    self))

(define dbl (new-daughter 'blue))

((dbl 'report))

((dbl 'convert) 'muslim)

((dbl 'report))

((dbl 'increase) 50000)

((dbl 'report))

(define dbr (new-daughter 'brown))

((dbr 'report))

((dbr 'decrease) 250000)

((dbr 'report))

((dbr 'bogus))

(set-debug-method-mode)

((dbr 'bogus))

(reset-debug-method-mode)