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 yet another version of GOOS. This time it is
implemented without modules. This version needs the
variable-bind-pair procedure I have been talking about.
However one could go in a hack out this dependency, but
you will lose eval-in-object and you will have to
modify make-class (simple mods).
I apologize about not having a proper print callback
function, but there does not seem to be any hook into
it without resorting to use structures or records, both
of which I do not want to use. See class-print, et. al.
for details.
The examples have also changed to add a class name
argument.
Wade
;; E X A M P L E S
;; Simple Class
(define person
(make-class 'person '()
(define *class-slots* '(all-persons))
(define *instance-slots* '(name age height weight))
(define all-persons '())
(define initialize-instance
(lambda (inst . args)
(initargs->slot-define! inst args 'name :name)
(initargs->slot-define! inst args 'age :age 'na)
(initargs->slot-define! inst args 'height :height 'na)
(initargs->slot-define! inst args 'weight :weight 'na)))))
(define wade (make-instance person :name 'wade :age 38 :height 171 :weight 70))
(define arline (make-instance person :name 'arline :age 38 :height 173 :weight 60))
;; Class with inheritance
(define elderly-person
(make-class 'elderly-person (list person)
(define *class-slots* '())
(define *instance-slots* '(retired))
(define initialize-instance
(lambda (inst . args)
(initargs->slot-define! inst args 'retired :retired)))))
(define dad (make-instance elderly-person
:retired #t
:name 'dad
:age 78
:height 190
:weight 90))
;; Class with multiple inheritance
(define wise-person
(make-class 'wise-person (list person elderly-person)
(define *class-slots* '())
(define *instance-slots* '(area-of-wisdom))
(define initialize-instance
(lambda (inst . args)
(initargs->slot-define! inst args 'area-of-wisdom :area-of-wisdom)))))
(define yasmin (make-instance wise-person
:name 'yasmin-manji
:age 45
:retired 'fat-chance
:area-of-wisdom 'yoga))
(define bo (make-instance wise-person
:name 'bo-lozoff
:retired 'never
:area-of-wisdom 'prison-system))
------------------ GOOS -------------------------------------------------------
;; GOOS v.0.3 for Guile. This version of GOOS is
;; implemented without modules. However some of it
;; is inspired by the Guile module system.
;
;; This code is freely given to the FSF.
(read-set! keywords 'prefix)
;; Object =====> (vector *object-tag* specialization name parents slots)
;; specialization - objects can be created that have specialties such as
;; records, classes and instances. Many extended types could
;; be constructed out of objects.
;; name - anything is possible
;; parents - list of parents (objects)
;; slots - stored as an association list
;;
;; Basic object accessors
(define *object-tag* "object")
(define (make-object specialization name parents . initial-slots)
(vector
*object-tag*
specialization
name
(begin
(for-each
(lambda (parent)
(if (not (object? parent))
(error "Object Parent Must Be Object:" parent)))
parents)
parents)
initial-slots))
(define (object? obj) (and (vector? obj) (eq? *object-tag* (vector-ref obj 0))))
(define (object-specialization obj) (vector-ref obj 1))
(define (object-name obj) (vector-ref obj 2))
(define (object-parents obj) (vector-ref obj 3))
(define (object-slots obj) (vector-ref obj 4))
(define (object-slot/value-add! obj slot/value)
(vector-set! obj 4 (cons slot/value (object-slots obj))))
(define object-local-slot/value-ref
(lambda (obj sym)
(assq sym (object-slots obj))))
(define object-apply-down-inheritance
(lambda (obj func)
(define traversed-inheritance '())
(define (apply-in-object obj)
(if (not (memq obj traversed-inheritance))
(begin
(func obj)
(for-each
(lambda (parent)
(apply-in-object parent))
(object-parents obj))
(set! traversed-inheritance (cons obj traversed-inheritance)))))
(apply-in-object obj)))
(define object-apply-up-inheritance
(lambda (obj func)
(define traversed-inheritance '())
(define (apply-in-object obj)
(if (not (memq obj traversed-inheritance))
(begin
(for-each
(lambda (parent)
(apply-in-object parent))
(reverse (object-parents obj)))
(func obj)
(set! traversed-inheritance (cons obj traversed-inheritance)))))
(apply-in-object obj)))
(define object-inheritance-list
(lambda (obj)
(define inheritance-list '())
(object-apply-up-inheritance
obj
(lambda (obj)
(set! inheritance-list (cons obj inheritance-list))))
(cdr inheritance-list)))
(define (object-slot/value-ref obj sym)
(catch 'object-slot/value-ref
(lambda ()
(object-apply-down-inheritance
obj
(lambda (parent)
(let ((slot/value (object-local-slot/value-ref parent sym)))
(if slot/value
(throw 'object-slot/value-ref slot/value)))))
#f)
(lambda (sym slot/value . rest) slot/value)))
(define (object-define! obj sym val)
(let ((slot/value (object-local-slot/value-ref obj sym)))
(if slot/value
(set-cdr! slot/value val)
(begin
(set! slot/value (cons sym val))
(object-slot/value-add! obj slot/value)))
slot/value))
(define (object-ref obj sym)
(let ((slot/value (object-slot/value-ref obj sym)))
(if slot/value
(cdr slot/value)
(error "No Slot Defined On Object:" sym))))
(define (object-set! obj sym val)
(let ((slot/value (object-slot/value-ref obj sym)))
(if slot/value
(set-cdr! slot/value val)
(error "No Slot Defined On Object:" sym))))
(define (object-defined? obj sym)
(if (object-slot/value-ref obj sym) #t #f))
;; Procedures for evaluation
(define object-lookup-closure
(lambda (obj)
(lambda (sym define?)
(if define?
(variable-bind-pair (object-define! obj sym #f))
(let ((slot/value (object-slot/value-ref obj sym)))
(if slot/value
(variable-bind-pair slot/value)
(*top-level-lookup-closure* sym define?)))))))
(define (eval-in-object exp obj)
(eval2 exp (object-lookup-closure obj)))
(define (eval-all-in-object elist obj)
(for-each
(lambda (exp)
(eval2 exp (object-lookup-closure obj)))
elist))
;; Start of class procedures
;; (make-class name supers . expressions)
(define make-class
(procedure->macro
(lambda (exp env)
`(let ((%%class%% (make-object 'class ,(cadr exp)
(if (null? ,(caddr exp))
(list the-standard-class)
,(caddr exp)))))
(eval-all-in-object ',(cdddr exp) %%class%%)
%%class%%))))
(define (make-instance class . inits)
(let ((inst (make-object 'instance (class-name class) (list class))))
(apply (slot-ref inst '%meta-initialize-instance-proc) (cons inst inits))
inst))
(define slot-ref object-ref)
(define slot-set! object-set!)
(define slot-define! object-define!)
(define slot-defined? object-defined?)
(define (slot-locally-defined? obj sym)
(let ((s (object-local-slot/value-ref obj sym)))
(if s #t #f)))
(define (class-name obj) (object-name obj))
(define slots object-slots)
(define supers object-parents)
(define (describe obj) ((slot-ref obj 'describe) obj))
(define (class? obj) (and (object? obj) (eq? (object-specialization obj) 'class)))
(define (instance? obj) (and (object? obj) (eq? (object-specialization obj) 'instance)))
(define (class-print obj) ((slot-ref obj '*printer*) obj))
(define inheritance-list object-inheritance-list)
(define (class-help obj)
(if (slot-locally-defined? obj '*documentation-string*)
(slot-ref obj '*documentation-string*)
"No Help Available"))
;; Initialization Args -
;; Init args 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 (initargs->slot-define! obj args sym key . default)
(let ((arg (memq key args)))
(if arg
(slot-define! obj sym (cadr arg))
(if (null? default)
(error "Missing required arg in initialization: " key)
(slot-define! obj sym (car default))))))
;; The Standard Class with Meta-Object Protocol (Methods)
;; for introspection and initialization of instances. Classes
;; are always objects within this system.
(define the-standard-class
(make-object 'class 'the-standard-class '()
(cons '*printer*
(lambda (obj . port)
(if (null? port) (set! port (current-output-port)))
(if (class? obj)
(display "#<class " port)
(display "#<instance " port))
(write (class-name obj) port)
(display ">" port)))
(cons 'describe
(lambda (obj)
(newline)
(display "slots: ") (write (slots obj)) (newline)
(display "supers: (")
(for-each
(lambda (parent)
(class-print parent) (display #\space))
(object-inheritance-list obj))
(display ")")
(newline)))
(cons '%meta-initialize-instance-proc
(lambda (inst . inits)
(define inst-inits (cons inst inits))
(object-apply-up-inheritance
inst
(lambda (class)
(let ((initialize-method
(object-local-slot/value-ref class 'initialize-instance)))
(if initialize-method
(apply (cdr initialize-method) inst-inits)))))))
(cons 'initialize-instance
(lambda (inst . args) #t))
)
)