This is the mail archive of the guile@cygnus.com mailing list for the guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

Re: forthcoming object system


Here is some food for thought for the new object
system.  This object system is simple but I think
it has a nice syntax, consistent with the scheme
philosophy.


;; Simple Object System - For Guile
;; These are objects are essentially closures with multiple
;; methods associated.  Generic methods are defined at the
;; top level allowing specific methods to be specified on an  object.
;; Inheritance is NOT supported as this can be added
;; later with additional macros.  However inheritance can
;; be simulated (see examples).  There is not alot of error
;; checking in the object-lambda macro.  Only a matter of
;; coding

(define *object-tag* "object")

(define object? 
  (lambda (obj) (and (vector? obj) (eq? (vector-ref obj 0)
*object-tag*))))

(define (get-method obj generic-method)
  (let ((method (assq generic-method (vector-ref obj 1))))
    (if method
	(cdr method)
	#f)))

(define (make-generic-method)
  (letrec ((self
	    (lambda (obj . args)
	      (if (object? obj)
		  (let ((method (get-method obj self)))
		    (if method
			(apply method args)
			(error "Operation not supported on object" obj)))
		  (error "Method being applied to non object: " obj)))))
    self))

;; (object-lambda formals . method-list) -->  #<object>

(define object-lambda
  (procedure->macro
   (lambda (exp env)
     `(lambda ,(cadr exp)
	(vector
	 *object-tag*
	 (list ,@(map
		  (lambda (method)
		    (if (eq? (car method) 'method)
			(begin
			  (if (not (defined? (cadr method)))
			      (eval `(define ,(cadr method) (make-generic-method))))
			  `(cons ,(cadr method)
				(lambda ,(caddr method) ,@(cdddr method))))))
		  (cddr exp))))))))

;; example
;; Object system has no inheritance, only uses relationships

(define make-person
  (object-lambda (name age)
		 (method get-name () name)
		 (method get-age () age)
		 (method set-name (new-name) (set! name new-name))))

(define wade (make-person 'wade 38))
(get-name wade)
(set-name wade 'fred)
(get-name wade)

;; Example of "psuedo" inheritence a.k.a "use" relationship
;; I guess macros could be defined to make it easier on the 
;; coder.

(define make-old-person
  (lambda (name age retired)
    ((object-lambda (person retired)
		    (method get-name () (get-name person))
		    (method get-age () (get-age person))
		    (method retired? () retired))
     (make-person name age)
     retired)))

(define dad (make-old-person 'andrew '78 #t))
(retired? dad)
(get-name dad)