If you peruse this and can answer for yourself what every single element does and why, you should be in great shape for future lambda- related and object-oriented meta-interpreter exam questions. The code has been modified to work in our LISP and the link indicates where the code can be found.
;;;Simple object system with inheritance
;;;Defines functions to create multiple
;;;turtle objects that exist visually by
;;;using functions from a turtle-graphics
;;;package. These functions are
;;;omitted here, because this
;;;package may not be loaded or available
;;;for all LISP environments. The example
;;;is provided for instructional purposes.
;;;It can still be run; there will simply
;;;be no graphical component.
;;;Function: ASK
;;;Meta-interpreter function that uses
;;;functional behavior (the cond-switch)
;;;of the lambda that is the given object to
;;;extract the lambda that implements the
;;;indicated message (the bodies of the
;;;cond-options) on that object with any
;;;necessary arguments
(defun ask (object message &rest args)
(let ((method (get-method object message)))
(if (method? method)
(apply method (cons object args))
(print "Error: No such method"))))
;;;Function: GET-METHOD
;;;Get-method applies the lambda which is
;;;the object instance to the argument
;;;message--a symbol selecting a behavior
;;;of the object. The object-lambda
;;;returns either an implementing lambda
;;;or the no-method error-pair below
(defun get-method (object message)
(funcall object message))
;;;Function: NO-METHOD
;;;Each object uses this function to return
;;;the pair (no-method ) when the
;;;object cannot find an implementation
;;;for the message (no match in the cond)
(defun no-method (name)
(list 'no-method name))
;;;Function: NO-METHOD?
;;;Used to check if what has been
;;;returned by get-method is valid or not
(defun no-method? (x)
(if (pair? x)
(equal (car x) 'no-method)
nil))
;;;Function: PAIR?
;;;This function is not implemented in all
;;;CommonLISP systems (it is from Scheme)
(defun pair? (x)
(if (listp x)
(equal (length x) 2)
nil))
;;;Function: METHOD?
;;;Used after get-method has applied
;;;the object-lambda to a message argument
;;;and returned either a lambda to implement
;;;the message or the length-2-list
;;;indicating an error
(defun method? (x)
(not (no-method? x)))
;;;A Base Class (has only a name)
;;;Function: MAKE-NAMED-OBJECT
(defun make-named-object (name)
#'(lambda (message)
(cond
((equal message 'name)
#'(lambda (self) name))
(t (no-method name)))))
;;;A Simple Turtle Class
;;;Function: MAKE-TURTLE
;;;Inherits from the above by having
;;;an instance of the above to which
;;;to delegate messages not known
(defun make-turtle (name place clr)
(let ((n-o (make-named-object name))
;;place is assumed to be a pair
(x (car place))
(y (cadr place))
(color clr)
(direction 0)
(width 10))
#'(lambda (message)
(cond
((equal message 'set-x)
#'(lambda (self x-loc) (setf x x-loc) x))
((equal message 'x)
#'(lambda (self) x))
((equal message 'set-y)
#'(lambda (self y-loc) (setf y y-loc) y))
((equal message 'y)
#'(lambda (self) y))
((equal message 'direction)
#'(lambda (self) direction))
((equal message 'set-color)
#'(lambda (self col) (setf color col) color))
((equal message 'color)
#'(lambda (self) color))
(t (get-method n-o message))))))
;;;Only base objects need to return an error-pair
;;;Inherited objects delegate to their parent
;;;The following expressions can be evaluated to
;;;test the above code. (Remove the comments
;;;of course).
;;;(setq bobo (make-named-object 'bobo))
;;;(ask bobo 'name)
;;;(ask bobo 'invalid)
;;;(setq tom (make-turtle 'tom '(2 3) 'blue))
;;;(ask tom 'x)
;;;(ask tom 'set-x 7)
;;;(ask tom 'x)
;;;(ask tom 'color)
;;;(ask tom 'name) ;;;Testing inheritance
;;;(ask tom 'dumb)