Tiny Object System

[wand%corwin.ccs.northeastern.edu@RELAY.CS.NET]

OK, here is my entry in the "smallest pedagogical OOPS".  It is not quite as
refined as I would like, but it's close.  Note that flavors and operations
(methods) are first-class citizens, more or less:  in particular, messages are
NOT quoted symbols.

-- Mitch Wand (wand@corwin.ccs.northeastern.edu)

;;; A Toy Flavors System in Scheme, based on Generic Functions
;;; or, Object-Oriented Programming without Objects

;;; In this version, we introduce a functional model of operations.

;;; Definitions of data structures:

;;; flavor = ([parent|nil] . instance-names)  
; cons-cell is hash code for unique flavor (test equality of flavors
; with eq?)
; instance-names are all required fields, beginning with ancestors and
; concluding with local names)

;;; instance = (flavor . instance-values)

;;; method = (cell operation)	 ; the cell is probably superfluous.

;;; operation = instance->flavor->operation->fcn

;;; An operation takes 3 arguments:  the INSTANCE, the FLAVOR of which
;;; it is supposed to be an instance, and another OPERATION (to be
;;; invoked upon inheritance), and produces a FCN to be applied to the
;;; instance. 

;;; fcn = lambda (self af1 ... af_k lf_1 ... lf_n . extra-fields) .
;;;         lambda (param_1 ... param_p) . M

;;; The point is that the fcn might be applied to an instance of a
;;; DESCENDENT of this flavor, so it will be a record consisting of
;;; the fields of this flavor (af_1 .. lf_n), plus some additional
;;; fields.


;;; Data Structures

(define make-cell (lambda (v) (cons v nil)))
(define deref-cell car)
(define set-cell! set-car!)

(define fl->parent cadr)
(define fl->instance-names cddr)
(define mk-fl (lambda (parent names) (cons '&flavor (cons parent names))))
(make-unprintable '&flavor '<FLAVOR>)

(define inst->flavor car)
(define inst->values cdr)
(define mk-inst cons)

;;; Functional Core

(define make-flavor
  (lambda (parent new-names)
    (mk-fl parent (append (fl->instance-names parent) new-names))))

;;; here is the empty method.  It tries to invoke inheritance if it
;;; can.  The third argument is the method to be used if inheritance
;;; is to be followed.  Note the implicit Y operator in the last line.

(define empty-method
  (lambda (instance flavor whole-method)
    (let ((parent (fl->parent flavor)))
      (if (null? parent)
          (error "Couldn't apply method" whole-method instance)
          (whole-method parent instance whole-method)))))

(define make-method
  (lambda ()
    (make-cell empty-method)))

;;; here is how we add a new "unit method" to an existing method.
;;; This is just the familiar notion of functional extension EXCEPT
;;; for the whole-method argument.  This is passed along as we search
;;; for an applicable method, and is eventually used by empty-method
;;; to invoke inheritance.

(define cons-composite-method
  (lambda (new-flavor new-fcn old-method)
    (lambda (instance flavor whole-method)
      (if (eq? flavor new-flavor)
	 (apply new-fcn
	  (cons instance (inst->values instance)))
         (old-method flavor instance whole-method)))))

(define add-method!
  (lambda (method flavor fcn)
    (set-cell! method
               (cons-composite-method flavor fcn (deref-cell method)))))

;;; Next we write some user-interfaces

; the null flavor has no parent and no fields

(define null-flavor '(nil))

; define new flavors with define-flavor

(extend-syntax (define-flavor)
  [(define-flavor name parent instance-name ...)
   (define name (make-flavor (if (null? parent) null-flavor parent)
			     '(instance-name ...)))])

; make new instances with make-instance.  Put parent values first,
; then local values.  This could use call-by-keyword, with a SMOP.

(extend-syntax (make-instance)
  [(make-instance flavor values ...)
   (list flavor values ...)])

; make new methods with define-method

(extend-syntax (define-method)
  [(define-method name)
   (define name (make-method))])

; add options to methods with add-method

(define expand-add-method
  (lambda (exp)
    (record-case exp
      [add-method (method flavor params body)
	(let ([bvl (cons 'self (append (fl->instance-names
					(execute (compile flavor)))
				       'extras))])
	 `(begin
	   (add-method! ,method ,flavor
		      (lambda ,bvl (lambda ,params ,body)))
	   ',method))])))

(macro add-method expand-add-method)

;;; apply-method is the user-level invocation of methods.  It
;;; evaluates and dereferences its method and object arguments exactly
;;; once.  Notice how real-method is passed as the third argument to
;;; itself in order to initiate the inheritance search loop.

(extend-syntax (apply-method)
  [(apply-method method object arg ...)
   (let ((real-method (deref-cell method))
         (real-object object))     
     ((real-method (inst->flavor real-object) real-object real-method)
      arg ...))])

;;; Just for laughs, here is a general setter:

(define-method :set)

(add-method :set null-flavor (name val)
	    (iterate loop
	      ([names (fl->instance-names (inst->flavor self))]
	       [vals  (inst->values self)])
	      (cond
		[(null? names) (error "cannot set " name)]
		[(eqv? (car names) name) (set-car! vals val) val]
		[else (loop (cdr names) (cdr vals))])))


(define-method :run-super)

(add-method :run-super null-flavor (method)
	    (let ((parent (fl->parent (inst->flavor self))))
	      (if (null? parent)
		  (error "no super")
		  (apply-method method (mk-inst parent (inst->values
							self))))))

  

;;; and here is a test file:

(define-flavor terminal () val)
(define-flavor Ident terminal)
(define-flavor Number terminal)
(define-flavor Compound () Operator argument1 argument2)
(define-flavor MulSym ())
(define-flavor AddSym ())

(define-method :eval)

(add-method :eval Number () val)

(add-method :eval Compound ()
	    (apply-method :operator-result Operator
			  (apply-method :eval argument1)
			  (apply-method :eval argument2)))

(define-method :operator-result)

(add-method :operator-result MulSym (v1 v2) (* v1 v2))
(add-method :operator-result AddSym (v1 v2) (+ v1 v2))


(define test1
  (lambda ()
    (let* ([mulsym (make-instance MulSym)]
	   [addsym (make-instance AddSym)]
	   [obj1 (make-instance Compound addsym 
		    (make-instance Number 5)
		    (make-instance Number 7))])
	  (writeln (apply-method :eval obj1) " = " 12)
	  (apply-method :set obj1 'Operator mulsym)
	  (writeln (apply-method :eval obj1) " = " 35))))