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