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: OOP and Relationship to the Guile Module System


Here is another release of GOOS (See the end of this message).
A few things have changed:

1) Removed the make-generic-method interface.  Its not
really necessary since procedures are the same as methods.

2) Modified slot-ref and slot-set! so calls will not be able
to modify bindings in the top level environment. i.e. the-root-module.

3) Classes are not required to have *class-slots*, *instance-slots*
or initialize-instance defined.

Here is another example of how GOOS could be used:

(define widget
  (make-class '()
     (define initialize-instance
       (lambda (inst . args)
	 (define (quick-define! sym key . default)
	   (let ((init (get-initarg key args)))
	     (if init
		 (slot-define! inst sym init)
		 (if (null? default)
		     (error "Missing arg in initialization" key)
		     (slot-define! inst sym (car default))))))

	 (quick-define! 'name :name)
	 (quick-define! 'parent-window :parent-window 'top-level)
	 (quick-define! 'state :state 'normal)))

     (define show
       (lambda (widget)
	 (let ((refresh (method-ref widget 'refresh)))
	   (refresh widget)
	   (slot-set! widget 'state 'normal))))))

(define window
  (make-class (list widget)

     (define initialize-instance
       (lambda (inst . args)
	 (define (quick-define! sym key . default)
	   (let ((init (get-initarg key args)))
	     (if init
		 (slot-define! inst sym init)
		 (if (null? default)
		     (error "Missing arg in initialization" key)
		     (slot-define! inst sym (car default))))))

	 (quick-define! 'title :title "Unknown")
	 (quick-define! 'position :position (list 0 0 100 150))
	 (quick-define! 'background-color :background-color 'black)
	 (quick-define! 'foreground-color :foreground-color 'white)))

     (define refresh
       (lambda (win graphics-stream)
	 ;; Do some graphics library specific routines))))
     

;; Make a window
(define window1 (make-instance window 
			       :name 'window1 
			       :title "Window 1" 
			       :state 'shrunk))

;; Provide a interface at the top level for accessing show. (Generic
method)
(define (show widget) ((method-ref widget 'show) widget))

;; bring window from shrunk state to normal
(show window1)

;; You could redefine all widget's show method dynamically.
;; This behaviour is automatically applies to current
;; instances such as window1.

(let ((old-show (method-ref widget 'show)))
  (slot-set! widget 'show
	     (lambda (widget)
	       (if (eq? (slot-ref widget 'state) 'normal)
		   #t ;; Do nothing
		   (old-show widget)))))

> Jim Blandy writes --
>
> Mikael Djurfeldt was really hot to give Guile a Meta-Object Protocol,
> which is (if my very shaky understanding serves me) a way to customize
> the implementation of the object system itself, in a class-like
> manner.  So, although the current module system isn't designed right
> to give things like this reasonable performance, it's conceivable
> that, by using different meta-classes, you could implement classes
> this way and get decent performance.

> But I must admit that I don't really understand the art of the
> meta-object protocol... which I should...


Well, neither do I.

Wade

------------------- Start of goos.scm --------------------------------

;; GOOS for Guile.  Classes and
;; instances are implemented as modules.
;
;; This code is freely given to the FSF for
;; use with Guile.

(read-set! keywords 'prefix)

(define (eval-all-in-module elist m)
  (if (null? elist)
      #t
      (begin 
	(eval-in-module (car elist) m)
	(eval-all-in-module (cdr elist) m))))

(define make-object
  (procedure->macro
   (lambda (exp env)
     `(let ((%%object%% (make-module 16 ,(cadr exp))))
	(eval-all-in-module ',(cddr exp) %%object%%)
        %%object%%))))

(define *the-root-class*
  (make-object (list the-root-module)
      (define *class-name* 'the-root-module)
      (define *class-slots* '())
      (define *instance-slots* '())
      (define class? module?)
      (define instance? module?)
      (define parents module-uses)
      (define slot-define! module-define!)
      (define slot-defined? module-defined?)
      (define slot-locally-bound? module-locally-bound?)

      (define (slot-ref obj sym)
	(if (slot-locally-bound? obj sym)
	    (module-ref obj sym)
	    (call-with-current-continuation
	     (lambda (escape)
	       (for-all-supers
		obj
		(lambda (class)
		  (if (slot-locally-bound? class sym)
		      (escape (module-ref class sym)))))
	       (error "No variable named" sym 'in obj)))))

      (define method-ref slot-ref)

      (define slot-set!
	(lambda (obj sym newval)
	  (if (slot-locally-bound? obj sym)
	      (module-set! obj sym newval)
	      (call-with-current-continuation
	       (lambda (escape)
		 (for-all-supers
		  obj
		  (lambda (class)
		    (if (slot-locally-bound? class sym)
			(escape (module-set! class sym newval)))))
		 (slot-define! obj sym newval))))))
	     
	  
      ;; Instance intialization list are of the form (<keyword> value
<keyword> value ...)

      (define (get-initarg key arglist)
	(let ((arg (memq key arglist)))
	  (if arg
	      (cadr arg)
	      (error "Arg does not exist with key: " key))))

      (define (initarg-in-list? key arglist)
	(if (memq key arglist) #t #f))

      (define class-name 
	(lambda (obj) (slot-ref obj '*class-name*)))

      (define for-all-supers
	(lambda (obj func)
	  (define traversed-classes '())
	  (define (apply-in-class class)
	    (if (not (or (eq? class the-root-module)
			 (memq class traversed-classes)))
		(begin
		  (for-each
		   (lambda (parent)
		     (apply-in-class parent))
		   (parents class))
		  (func class)
		  (set! traversed-classes (cons class traversed-classes)))))
	  
	  (let ((superclasses (parents obj)))
	    (for-each
	     (lambda (superclass)
	       (apply-in-class superclass))
	     (parents obj)))))

      (define class-slots 
	(lambda (obj) 
	  (letrec ((cslist '())
		   (collector 
		    (lambda (class) 
		      (if (slot-locally-bound? class '*class-slots*)
			  (set! cslist (cons (slot-ref class '*class-slots*) cslist))))))
	    (for-all-supers obj collector)
	    (if (slot-locally-bound? obj '*class-slots*)
		(set! cslist (cons (slot-ref obj '*class-slots*) cslist)))
	    (apply append cslist))))

      (define instance-slots 
	(lambda (obj) 
	  (letrec ((cslist '())
		   (collector 
		    (lambda (class) 
		      (if (slot-locally-bound? class '*instance-slots*)
			  (set! cslist (cons (slot-ref class '*instance-slots*) cslist))))))
	    (for-all-supers obj collector)
	    (if (slot-locally-bound? obj '*instance-slots*)
		(set! cslist (cons (slot-ref obj '*instance-slots*) cslist)))
	    (apply append cslist))))

      (define describe 
	(lambda (obj)
	  (list (cons 'class (class-name obj))
		(cons 'class-slots (class-slots obj))
		(cons 'instance-slots (instance-slots obj)))))

      (define initialize-instance (lambda (obj . args) #t))))

(define class? (module-ref *the-root-class* 'class?))
(define instance? (module-ref *the-root-class* 'instance?))
(define slot-ref (module-ref *the-root-class* 'slot-ref))
(define slot-set! (module-ref *the-root-class* 'slot-set!))
(define method-ref (module-ref *the-root-class* 'method-ref))
(define slot-define! (module-ref *the-root-class* 'slot-define!))
(define slot-defined? (module-ref *the-root-class* 'slot-defined?))
(define slot-locally-bound? (module-ref *the-root-class*
'slot-locally-bound?))
(define get-initarg (module-ref *the-root-class* 'get-initarg))
(define initarg-in-list? (module-ref *the-root-class*
'initarg-in-list?))
(define describe (module-ref *the-root-class* 'describe))
(define class-name (module-ref *the-root-class* 'class-name))
(define class-slots (module-ref *the-root-class* 'class-slots))
(define instance-slots (module-ref *the-root-class* 'instance-slots))
(define parents (module-ref *the-root-class* 'parents))
(define for-all-supers (module-ref *the-root-class* 'for-all-supers))

(define make-class
  (procedure->macro
   (lambda (exp env)
     `(make-object 
       (if (null? ,(cadr exp))
	   (list *the-root-class*)
	   ,(cadr exp))
       ,@(cddr exp)))))

;; Should not be called directly
(define %initialize-instance
  (lambda (inst . inits)
    (define inst-inits (cons inst inits))
    (for-all-supers 
     inst
     (lambda (class) 
       (if (slot-locally-bound? class 'initialize-instance)
	   (apply (module-ref class 'initialize-instance) inst-inits))))))

(define (make-instance class . inits)
  (let ((inst (make-object (list class))))
    (apply %initialize-instance (cons inst inits))
    inst))