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] |
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))