Path: utzoo!attcan!utgpu!jarvis.csri.toronto.edu!mailrus!cs.utexas.edu!uunet!mcsun!sunic!liuida!mikpe
From: mikpe@majestix.ida.liu.se (Mikael Pettersson)
Newsgroups: comp.lang.lisp.x
Subject: xscheme oop package
Summary: I've written a working(?) replacement
Keywords: oop, xscheme
Message-ID: <1341@majestix.ida.liu.se>
Date: 15 Sep 89 21:25:08 GMT
Organization: CIS Dept, Univ of Linkoping, Sweden
Lines: 434


As I've mentioned in some private email, I've been working on possibly
fixing or replacing the broken OOP stuff in xscheme. Well, it's time to
deliver! The following two files implement, in Scheme, an object mechanism
that is supposed to be near 100% compatible with those in xscheme and xlisp.
Some known limitations exists, see the header of the first file for details.

The first file, OBJ.SCM, is the actual implementation; the second, OTEST.SCM,
contains some tests. See the comments for further details.

I would appreciate if you would communicate bug reports and suggestions for
improvements back to me (unlike Mr Betz, my email address works :-).


	/Mike

(p.s. thanx to David Crabb for testing earlier versions of this package)



>>>> cut here for OBJ.SCM >>>>
;; OBJ.SCM -- A simple class mechanism for XScheme
;; by: Mikael Pettersson, mpe@ida.liu.se
;; This software is in the public domain
;; (no warranty, use at your own risk etc)
;;
;; Version 1.0		Sep 15, 1989	(mpe@ida.liu.se)
;;			Released to comp.lang.lisp.x
;;
;;
;; Implementation notes
;; ====================
;; An object is represented by a closure with bindings for the
;; state vectors of itself and its class.
;;
;; Instances have the following state structure:
;;	pos				contents
;;	---				--------
;;	0				self (the closure)
;;	1..1+(# of inst vars)-1		instance variable values
;;
;; Classes have the following state structure:
;;	pos				contents
;;	---				--------
;;	0				self (the closure)
;;	1				list of (message . method) pairs
;;	2				list of instance variable names
;;	3				list of class variable names
;;	4				vector of class variable values
;;	5				the state of the superclass
;;	6				number of class instance variables
;;	7				total number of instance variables
;;
;; Methods execute in a pseudo-environment (see cl-answer) with bindings
;; for SELF and the instance and class variables. Free variables are
;; evaluated in the global environment.
;;
;; Sending a message to the superclass (from inside a method) is done with
;; (self 'send-super msg ...). For backwards compability, the old form
;; (send-super msg ...) is supplied as a macro.
;;
;; Class variables can be given initial values with
;; (Class 'new '(ivar1 .. ivari) '((cvar1 val1) .. (cvarj valj)) ..).
;; An omitted initial value defaults to '().
;;
;; Limitations
;; ===========
;; Object? is not implemented
;; print et al prints objects as unnamed procedures, which is counterintuitive
;; performance(?)
;; instance and class variables can't be rebound in a method's body


;;
;; exported objects, procedures and macros
;;

(define Object)
(define Class)
(define (object? x) #f)
(macro send-super (lambda (form) `(self 'send-super ,@(cdr form))))

;;
;; internal state access/update macros
;;

(macro mkvref
  (lambda (form)
    (let ((i (cadr form)))
      (lambda (form)
	`(vector-ref ,(cadr form) ,i)))))
(macro mkvset
  (lambda (form)
    (let ((i (cadr form)))
      (lambda (form)
	`(vector-set! ,(cadr form) ,i ,(caddr form))))))
(macro get-self (mkvref 0))
(macro set-self! (mkvset 0))
(macro get-messages (mkvref 1))
(macro set-messages! (mkvset 1))
(macro get-ivars (mkvref 2))
(macro set-ivars! (mkvset 2))
(macro get-cvars (mkvref 3))
(macro set-cvars! (mkvset 3))
(macro get-cvals (mkvref 4))
(macro set-cvals! (mkvset 4))
(macro get-super-state (mkvref 5))
(macro set-super-state! (mkvset 5))
(macro get-ivarcnt (mkvref 6))
(macro set-ivarcnt! (mkvset 6))
(macro get-ivartotal (mkvref 7))
(macro set-ivartotal! (mkvset 7))

;;
;; make a package to hide the implementation details
;;

(let ()

;;
;; misc. stuff
;;

(define class-size 7)

(define (new-object-state slots)
  (make-vector (1+ slots)))	; add one for SELF

(define (make-object obj-state cls-state)
  (lambda (msg . argl)
    (send cls-state cls-state obj-state msg argl)))

(define (send cls-state o-cls-state obj-state msg argl)
  ;; cls-state is where we begin searching for the method
  ;; o-cls-state is the original class-state for 'self'
  ;; (needed for some built-in methods)
  ;; obj-state is the state for 'self'
  (let (m)
    (while (and cls-state
		(begin (set! m (assq msg (get-messages cls-state)))
		       (null? m)))
      (set! cls-state (get-super-state cls-state)))
    (if m
	((cdr m) obj-state o-cls-state (get-cvals cls-state) argl)
	(error "no method for this message" msg (get-self obj-state)))))

(define (assert-null! argl who)
  (and argl (error "too many arguments" who argl)))

;;
;; default methods for Object
;;

;; 'send-super -- send to the super class
(define (ob-send-super self-state cls-state cvals argl)
  (send (get-super-state cls-state) cls-state self-state (car argl) (cdr argl)))

;; 'isnew -- default 'isnew method
(define (ob-isnew self-state cls-state cvals argl)
  (assert-null! argl 'ISNEW)
  (get-self self-state))

;; 'class -- get the class of an object
(define (ob-class self-state cls-state cvals argl)
  (assert-null! argl 'CLASS)
  (get-self cls-state))

;; 'show -- show the instance variables of an object
(define (ob-show self-state cls-state cvals argl)
  (let ((port (if argl
		  (begin
		    (assert-null! (cdr argl) 'SHOW)
		    (car argl))
		  (current-output-port))))

    ;; print the object and class
    (princ "Object is " port)
    (princ (get-self self-state) port)
    (princ ", Class is " port)
    (princ (get-self cls-state) port)
    (newline port)

    ;; print the object's instance variables
    (ob-show-vars port (get-ivars cls-state) self-state 1)

    ;; return the object
    (get-self self-state)))

(define (ob-show-vars port ivars-list obj-state pos)
  (while ivars-list
    (princ #\space port)
    (princ (car ivars-list) port)
    (princ " = " port)
    (princ (vector-ref obj-state pos) port)
    (newline port)
    (set! pos (1+ pos))
    (set! ivars-list (cdr ivars-list))))

;; '%state -- get the state vector for an object (used by cl-isnew)
(define (ob-state self-state cls-state cvals argl)
  (assert-null! argl '%STATE)
  self-state)

;;
;; default methods for Class
;;

;; 'new -- create a new object instance
(define (cl-new self-state cls-state cvals argl)
  (let ((obj-state (new-object-state (get-ivartotal self-state))))
    (set-self! obj-state (make-object obj-state self-state))
    (send self-state self-state obj-state 'isnew argl)))

;; 'isnew -- initialize a new class
(define (cl-isnew self-state cls-state cvals argl)
  (let (ivars cvars super-state n)
    (set! ivars (car argl))
    (set! argl (cdr argl))
    (set! super-state Object-state)
    (if argl
	(begin
	  (set! cvars (car argl))
	  (set! argl (cdr argl))
	  (if argl
	      (begin
		(set! super-state ((car argl) '%state))	; invoke ob-state
		(assert-null! (cdr argl) 'ISNEW)))))

    ;; store the instance and class variable lists and the superclass
    (set-ivars! self-state (append (get-ivars super-state) (append ivars '())))
    (if cvars
	(let ((naml (map (lambda (x) (if (symbol? x) x (car x)))
			 cvars))
	      (vals (map (lambda (x) (if (symbol? x) '() (cadr x)))
			 cvars)))
	  (set-cvals! self-state (list->vector vals))
	  (set-cvars! self-state naml)))
    (set-super-state! self-state super-state)

    ;; compute the instance variable count
    (set! n (length ivars))
    (set-ivarcnt! self-state n)
    (set-ivartotal! self-state (+ n (get-ivartotal super-state)))

    ;; return the new class object
    (get-self self-state)))

;; 'answer -- define a method for answering a message
(define (cl-answer self-state cls-state cvals argl)
  (let (msg fargs code)
    ;; message symbol, formal argument list and code
    (set! msg (car argl))
    (set! argl (cdr argl))
    (set! fargs (car argl))
    (set! argl (cdr argl))
    (set! code (car argl))
    (assert-null! (cdr argl) 'ANSWER)

    ;; hack the code: expand all macro calls and change references to
    ;; instance or class variables into references to the state vectors
    ;; passed as arguments by send. SELF is the implicit ivar #0.
    (set! code (hack-list (%expand-macros code)
			  (get-cvars self-state)
			  (cons 'self (get-ivars self-state))))

    ;; make it look like a method
    (set! code `(lambda (%ivals %cls-state %cvals %argl)
		  (apply (lambda ,fargs ,@code) %argl)))

    ;; compile and store the method
    ;; (could use `eval' instead, but this saves us from copying the entire
    ;; s-expr again while trying to expand the non-existant macro calls)
    (entermsg! self-state msg ((%compile code)))

    ;; return the object
    (get-self self-state)))

(define (hack-list lst cvars ivars)
  (map (lambda (item) (hack-item item cvars ivars)) lst))

;; bugs: doesn't handle the binding forms (lambda, let et al).
(define (hack-item item cvars ivars)
  (if (pair? item)
      (let ((func (car item))
	    (args (cdr item)))
	(cond ((eq? func 'quote)
	       item)
	      ((eq? func 'set!)
	       (let ((pos (or (hack-symbol (car args) ivars 0 '%ivals)
			      (hack-symbol (car args) cvars 0 '%cvals))))
		 (if pos
		     `(vector-set! ,@pos ,(hack-item (cadr args) cvars ivars))
		     `(set! ,(car args) ,(hack-item (cadr args) cvars ivars)))))
	      (else
	       (hack-list item cvars ivars))))
      (let ((pos (and (symbol? item)
		      (or (hack-symbol item ivars 0 '%ivals)
			  (hack-symbol item cvars 0 '%cvals)))))
	(if pos
	    `(vector-ref ,@pos)
	    item))))

(define (hack-symbol sym lst cnt foo)
  (while (and lst
	      (not (eq? sym (car lst))))
    (set! cnt (1+ cnt))
    (set! lst (cdr lst)))
  (and lst
       `(,foo ,cnt)))

(define (entermsg! state msg val)
  (let* ((mlist (get-messages state))
	 (pair (assq msg mlist)))
    (if pair
	(set-cdr! pair val)
	(set-messages! state (cons (cons msg val) mlist)))))

;;
;; create and initialize the Object and Class objects
;;

(define Class-state)
(define Object-state)

(set! Class-state (new-object-state class-size))
(set! Class (make-object Class-state Class-state))
(set-self! Class-state Class)
(set! Object-state (new-object-state class-size))
(set! Object (make-object Object-state Class-state))
(set-self! Object-state Object)

(set-ivarcnt! Object-state 0)
(set-ivartotal! Object-state 0)
(entermsg! Object-state 'send-super ob-send-super)
(entermsg! Object-state 'isnew ob-isnew)
(entermsg! Object-state 'class ob-class)
(entermsg! Object-state 'show ob-show)
(entermsg! Object-state '%state ob-state)		; used by cl-isnew

(set-ivars! Class-state '(messages ivars cvars cvals super-state ivarcnt ivartotal))
(set-ivarcnt! Class-state class-size)
(set-ivartotal! Class-state class-size)
(set-super-state! Class-state Object-state)
(entermsg! Class-state 'new cl-new)
(entermsg! Class-state 'isnew cl-isnew)
(entermsg! Class-state 'answer cl-answer)

;; close the package
)

;; 
;; remove our macros (it's a pity macros aren't statically scoped)
;;

(put 'mkvref '%macro '())
(put 'mkvset '%macro '())
(put 'get-self '%macro '())
(put 'set-self! '%macro '())
(put 'get-messages '%macro '())
(put 'set-messages! '%macro '())
(put 'get-ivars '%macro '())
(put 'set-ivars! '%macro '())
(put 'get-cvars '%macro '())
(put 'set-cvars! '%macro '())
(put 'get-cvals '%macro '())
(put 'set-cvals! '%macro '())
(put 'get-super-state '%macro '())
(put 'set-super-state! '%macro '())
(put 'get-ivarcnt '%macro '())
(put 'set-ivarcnt! '%macro '())
(put 'get-ivartotal '%macro '())
(put 'set-ivartotal! '%macro '())
<<<< end of OBJ.SCM <<<<

>>>> cut here for OTEST.SCM >>>>
;; OTEST.SCM: test OBJ.SCM

(define BinaryTree (Class 'new '(l r)))
(BinaryTree 'answer 'isnew '(ll rr) '(
	(set! l ll)
	(set! r rr)
	self))
(BinaryTree 'answer 'print '() '(
	(princ "[")
	(l 'print)
	(princ ",")
	(r 'print)
	(princ "]")))

(define Tree (Class 'new '() '() BinaryTree))	; inherit 'isnew and 'print
(Tree 'answer 'length '() '(
	(+ (l 'length) (r 'length))))

(define Leaf (Class 'new '(id) '((cnt 0))))
(Leaf 'answer 'isnew '(val) '(
	(set! cnt (1+ cnt))
	(set! id val)
	self))
(Leaf 'answer 'print '() '(
	(princ id)))
(Leaf 'answer 'length '() '(
	1))

;; create some Leaves
(define a (Leaf 'new 'aa))
(define b (Leaf 'new 'bb))
(define c (Leaf 'new 'cc))
(Leaf 'show)	; cvals = #(3)

;; test 'send-super
(define SubLeaf (Class 'new '() '() Leaf))
(SubLeaf 'answer 'print '() '(		; override inherited method
	(princ "no-no")))
(SubLeaf 'answer 'please-print '() '(
	(self 'send-super 'print)))
(define aSubLeaf (SubLeaf 'new 'zz))
(aSubLeaf 'print)		; no-no
(aSubLeaf 'please-print)	; ZZ

;; create a BinaryTree
(define btree (BinaryTree 'new a (Tree 'new b c)))
(btree 'print)	; [AA,[BB,CC]]

;; create a Tree
(define t (Tree 'new (Tree 'new a b) c))
(t 'print)	; [[AA,BB],CC]
(t 'length)	; 3

;; force an error: "no method for this message"
(btree 'length)
<<<< end of OTEST.SCM <<<<
-- 
Mikael Pettersson, Dept of Comp & Info Sci, University of Linkoping, Sweden
email: mpe@ida.liu.se  or  ..!{mcvax,munnari,uunet}!enea!liuida!mpe