[comp.lang.lisp.x] xscheme oop package

mikpe@majestix.ida.liu.se (Mikael Pettersson) (09/16/89)

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

mikpe@senilix.ida.liu.se (Mikael Pettersson) (09/17/89)

In article <1341@majestix.ida.liu.se> I wrote:
>... The following two files implement, in Scheme, an object mechanism
>that is supposed to be near 100% compatible with those in xscheme and xlisp.

Oops! Except for some bugs in the handling of class variables that is :-(
(methods could execute in the wrong class context and class variables weren't
inherited properly). The following context diff to "obj.scm" should fix this.

Sorry 'bout the inconvenience.

	/Mike

*** obj.scm.~1~	Fri Sep 15 22:35:57 1989
--- obj.scm	Sat Sep 16 19:22:09 1989
***************
*** 6,12 ****
--- 6,15 ----
  ;; Version 1.0		Sep 15, 1989	(mpe@ida.liu.se)
  ;;			Released to comp.lang.lisp.x
  ;;
+ ;; Version 1.1		Sep 16, 1989	(mpe@ida.liu.se)
+ ;;			Fixed some bugs in class variable handling
  ;;
+ ;;
  ;; Implementation notes
  ;; ====================
  ;; An object is represented by a closure with bindings for the
***************
*** 29,34 ****
--- 32,38 ----
  ;;	5				the state of the superclass
  ;;	6				number of class instance variables
  ;;	7				total number of instance variables
+ ;;	8				list of initial class variable values
  ;;
  ;; Methods execute in a pseudo-environment (see cl-answer) with bindings
  ;; for SELF and the instance and class variables. Free variables are
***************
*** 89,94 ****
--- 93,100 ----
  (macro set-ivarcnt! (mkvset 6))
  (macro get-ivartotal (mkvref 7))
  (macro set-ivartotal! (mkvset 7))
+ (macro get-cinits (mkvref 8))
+ (macro set-cinits! (mkvset 8))
  
  ;;
  ;; make a package to hide the implementation details
***************
*** 100,106 ****
  ;; misc. stuff
  ;;
  
! (define class-size 7)
  
  (define (new-object-state slots)
    (make-vector (1+ slots)))	; add one for SELF
--- 106,112 ----
  ;; misc. stuff
  ;;
  
! (define class-size 8)
  
  (define (new-object-state slots)
    (make-vector (1+ slots)))	; add one for SELF
***************
*** 112,118 ****
  (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
--- 118,123 ----
***************
*** 120,126 ****
  		       (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)
--- 125,131 ----
  		       (null? m)))
        (set! cls-state (get-super-state cls-state)))
      (if m
! 	((cdr m) obj-state o-cls-state (get-cvals o-cls-state) argl)
  	(error "no method for this message" msg (get-self obj-state)))))
  
  (define (assert-null! argl who)
***************
*** 207,219 ****
  
      ;; 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
--- 212,227 ----
  
      ;; store the instance and class variable lists and the superclass
      (set-ivars! self-state (append (get-ivars super-state) (append ivars '())))
!     (set-cvars! self-state
! 		(append (get-cvars super-state)
! 			(map (lambda (x) (if (symbol? x) x (car x))) cvars)))
!     (if (get-cvars self-state)
! 	(begin
! 	  (set-cinits! self-state
! 		       (append (get-cinits super-state)
! 			       (map (lambda (x) (if (symbol? x) '() (cadr x)))
! 				    cvars)))
! 	  (set-cvals! self-state (list->vector (get-cinits self-state)))))
      (set-super-state! self-state super-state)
  
      ;; compute the instance variable count
***************
*** 316,322 ****
  (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)
--- 324,330 ----
  (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 cinits))
  (set-ivarcnt! Class-state class-size)
  (set-ivartotal! Class-state class-size)
  (set-super-state! Class-state Object-state)
***************
*** 349,351 ****
--- 357,361 ----
  (put 'set-ivarcnt! '%macro '())
  (put 'get-ivartotal '%macro '())
  (put 'set-ivartotal! '%macro '())
+ (put 'get-cinits '%macro '())
+ (put 'set-cinits! '%macro '())
-- 
Mikael Pettersson, Dept of Comp & Info Sci, University of Linkoping, Sweden
email: mpe@ida.liu.se  or  ..!{mcvax,munnari,uunet}!enea!liuida!mpe

mikpe@majestix.ida.liu.se (Mikael Pettersson) (09/17/89)

In article <1343@senilix.ida.liu.se> I wrote:
>In article <1341@majestix.ida.liu.se> I wrote:
>>... The following two files implement, in Scheme, an object mechanism
>>that is supposed to be near 100% compatible with those in xscheme and xlisp.
>
>Oops! Except for some bugs in the handling of class variables that is :-(
>(methods could execute in the wrong class context and class variables weren't
>inherited properly). The following context diff to "obj.scm" should fix this.

Arrgh! No it didn't. Class variables *still* weren't handled properly, as
it *copied* the superclass's cvars, rather than *sharing* them. Sigh.

Anyway, 'tis fixed now. The context diff being almost as big as the
file to apply it to, I post the file rather than the diff.


;; 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
;;
;; Version 1.1		Sep 16, 1989	(mpe@ida.liu.se)
;;			Fixed some bugs in class variable handling
;;
;; Version 1.2		Sep 17, 1989	(mpe@ida.liu.se)
;;			Fixed more bugs in the handling of class variables
;;
;;
;; 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..(# of inst vars)		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				a pair whose car is the list of class
;;					variable names, and cdr references the
;;					same field in the superclass
;;	4				a vector where slot #0 references the
;;					same field in the superclass, and slots
;;					#1..<number of class vars> contain the
;;					class variable values
;;	5				the superclass' state
;;	6				number of class instance variables
;;	7				total number of instance variables
;;
;; Fields (3) and (4) together make up a "class variable environment".
;;
;; 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'
  ;; 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 variable list and the superclass
    (set-ivars! self-state (append (get-ivars super-state) (append ivars '())))
    (set-super-state! self-state super-state)

    ;; construct the class variable environment
    (set-cvars! self-state	; method compile-time lookup structure
		(cons (map (lambda (x) (if (symbol? x) x (car x))) cvars)
		      (get-cvars super-state)))
    (set-cvals! self-state	; method run-time storage structure
		(list->vector (cons (get-cvals super-state)
				    (map (lambda (x)
					   (if (symbol? x) '() (cadr x)))
					 cvars))))

    ;; 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 ((nam (car args))
		     (val (hack-item (cadr args) cvars ivars)))
		 (or (hack-ivar-set nam val ivars)
		     (hack-cvar #f val nam cvars)
		     `(set! ,nam ,val))))
	      (else
	       (hack-list item cvars ivars))))
      (or (and (symbol? item)
	       (or (hack-ivar-ref item ivars)
		   (hack-cvar #t '() item cvars)))
	  item)))

(define (find-pos-in-list sym lst)
  (let ((pos 0))
    (while (and lst
		(not (eq? sym (car lst))))
      (set! pos (1+ pos))
      (set! lst (cdr lst)))
    (and lst pos)))

(define (hack-ivar-ref sym lst)
  (let ((pos (find-pos-in-list sym lst)))
    (and pos
	 `(vector-ref %ivals ,pos))))

(define (hack-ivar-set sym val lst)
  (let ((pos (find-pos-in-list sym lst)))
    (and pos
	 `(vector-set! %ivals ,pos ,val))))

(define (hack-cvar isref val sym cvars)
  (let ((frame 0) pos)
    (while (and cvars
		(begin (set! pos (find-pos-in-list sym (car cvars)))
		       (null? pos)))
      (set! frame (1+ frame))
      (set! cvars (cdr cvars)))
    (and cvars
	 (let ((name '%cvals))
	   (while (> frame 0)
	     (set! name `(vector-ref ,name 0))
	     (set! frame (-1+ frame)))
	   (if isref
	       `(vector-ref ,name ,(1+ pos))
	       `(vector-set! ,name ,(1+ pos) ,val))))))

(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 '())
-- 
Mikael Pettersson, Dept of Comp & Info Sci, University of Linkoping, Sweden
email: mpe@ida.liu.se  or  ..!{mcvax,munnari,uunet}!enea!liuida!mpe