🚀 go-pugleaf

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