brian@jade.jpl.nasa.gov (Brian of ASTD-CP) (07/02/89)
; 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)brian@jade.jpl.nasa.gov (Brian of ASTD-CP) (07/03/89)
; methods.scm (ADDENDUM) ; ; =============================================================== ; Brian Beckman | brian@topaz.jpl.nasa.gov ; Mail Stop 510-202 | (818) 397-9207 ; Jet Propulsion Laboratory | ; Pasadena, CA 91109 | 30 June 1989 ; =============================================================== ; There are two ways to invoke a method in an object. The ; first is to send the object a message, getting back a procedure. ; This procedure can then be invoked at will on an appropriate ; set of arguments. Such an idiom usually results in expressions ; like the following: ; ; ((foo 'do-it) arg1 arg2) ; ; This is fairly readable and a fine idiom, but it has its ; limitations. Suppose that this expression were to result in ; another object, to which we should like to send the message ; 'baz with the arguments 'rat and 'ter. Then we should write ; the following: ; ; ((((foo 'do-it) arg1 arg2) 'baz) 'rat 'ter) ; ; The number of leading parentheses is a problem. It is easy ; to devise nested message passing expressions that are ; much more difficult to write than to devise, merely because of ; the number of leading parentheses that must be presaged. Lisp ; already has a problem with closing parentheses; we don't want ; to compound the felony in this package by introducing a ; corresponding problem with opening parentheses. ; ; We need a ``send'' routine that does little more than reduce ; the need for leading parenthese. This is, admittedly, merely ; a syntactic issue. Consider the following, which is the second ; way to send a message to an object: (define (send object msg . args) (apply (object msg) args)) ; The earlier example message passing expressions can now be ; much more easly written much more nicely, as follows: ; ; (send object 'msg arg1 arg2) ; ; and ; ; (send (send object 'msg arg1 arg2) 'baz 'rat 'ter)
brian@topaz.jpl.nasa.gov (Brian of ASTD-CP) (07/06/89)
; This'll be my last submission on this topic, so I promise I won't
; be burning up the wires with any more. I thought a serious
; example would be of some interest, however, so here is a FIFO
; queue data type. I'll be building classes for priority queues,
; heaps, splay trees, and assorted others, as well as a data flow
; executive. Anyone interested further in this topic may feel
; free to e-mail me. Again, sorry for the length of these sub-
; missions. BCB.
;================================================================
;| Brian Beckman | brian@topaz.jpl.nasa.gov |
;| Mail Stop 510-202 | (818) 397-9207 |
;| Jet Propulsion Laboratory | |
;| Pasadena, CA 91109 | 3 July 1989 |
;================================================================
;;; Adapted from Abelson & Sussman, Ch. 3, Pg 208 ff.
;;; Uses the ``methods'' OOP package. This is an expanded,
;;; industrial-strength solution to Exercise 3.22 of A & S.
(define (new-queue . initial-list)
(let ( (q (cons () ()))
(dummy (if (not (null? initial-list))
(set! initial-list (car initial-list))))
(supers ()) )
(define (head) (car q))
(define (tail) (cdr q))
(define (set-head! item) (set-car! q item))
(define (set-tail! item) (set-cdr! q item))
(define (empty-queue?) (null? (head)))
(define (front)
(if (send self 'empty?)
(error "FRONT called on empty queue")
(car (head))))
(define (insert-queue! item)
(let ((elt (cons item ()))) ; could be (list item)
(cond
( (send self 'empty?)
(set-head! elt)
(set-tail! elt)
self )
( else
(set-cdr! (tail) elt)
(set-tail! elt)
self ))))
(define (insert-list! lyst)
(cond
( (null? lyst) self )
( else
(send self 'insert! (car lyst))
(insert-list! (cdr lyst)) )))
(define (remove-queue!)
(cond
( (send self 'empty?)
(error "REMOVE called on empty queue") )
( else
(set-head! (cdr (head))) self)))
(define (clear-queue!)
(set! q (cons () ()))
self)
(define (print) (display (head)) (newline))
(define (self msg)
(cond
( (eq? msg 'insert!) insert-queue! )
( (eq? msg 'empty?) empty-queue? )
( (eq? msg 'remove!) remove-queue! )
( (eq? msg 'clear!) clear-queue! )
( (eq? msg 'front) front )
( (eq? msg 'print) print )
( (eq? msg 'list) (lambda () (head)) )
( (eq? msg 'insert-list!) insert-list! )
( (search-supertypes supers msg) )
( else (make-error-method "Queue" msg) )))
(insert-list! initial-list) ;;; returns ``self''
))
;;; end of new-queue
; Test suite for queues.
(define q (new-queue '(a b c d e)))
(send q 'print)
(send q 'list)
(send (send q 'remove!) 'print)
(send q 'empty?)
(send (send q 'clear!) 'empty?)
(send q 'print)
(define q (new-queue))
(send q 'empty?)