; This file is part of CGEN.
; See file COPYING.CGEN for details.
;
-; When Guile has an official object implementation that is stable, things will
-; be switched over then. Until such time, there's no point in getting hyper
-; (although doing so is certainly fun, but only to a point).
-; If the Guile team decides there won't be any official object system
-; (which isn't unreasonable) then we'll pick the final object system then.
-; Until such time, there are better things to do than trying to build a
-; better object system. If this is important enough to you, help the Guile
-; team finish the module(/object?) system.
+; Scheme implementations don't agree on a lot of things beyond the basics.
+; This is a simple object system for cgen's needs.
+; I thought at the start that when Guile had an official object system
+; we'd switch over, but the higher order bit now is to be usable on
+; multiple Scheme implementations: Guile isn't fast enough.
+;
+; NOTE: The original COS supported multiple inheritance. This does not.
;
; Classes look like:
;
; #(class-tag
; class-name
-; parent-name-list
-; elm-alist
-; method-alist
-; full-elm-initial-list
-; full-method-alist ; ??? not currently used
+; class-uid ; unique id of class, index into /class-table
+; parent-name
+; elm-alist ; not including parent classes
+; method-alist ; not including parent classes
+; full-elm-initial-list ; including parent classes
+; method-cache ; ??? not currently used
; class-descriptor)
;
-; PARENT-NAME-LIST is a list of the names of parent classes (the inheritance
-; tree).
+; PARENT-NAME is the name of the parent class, if any.
+; If a subclasses b which subclasses c, then parent-name for a is b,
+; the parent-name for b is c, and the parent-name for c is #f.
;
-; ELM-ALIST is an alist of (symbol private? vector-index . initial-value)
+; ELM-ALIST is an alist of (symbol vector-offset-with-class . initial-value)
; for this class only.
; Values can be looked up by name, via elm-make-[gs]etter routines, or
; methods can use elm-get/set! for speed.
; Various Lisp (or Lisp-like) OOP systems (e.g. CLOS, Dylan) call these
; "slots". Maybe for consistency "slot" would be a better name. Some might
-; confuse that with intentions at directions. Given that something better
-; will eventually happen, being deliberately different is useful.
+; confuse that with intentions at directions.
;
-; METHOD-ALIST is an alist of (symbol . procedure) for this
-; class only.
+; METHOD-ALIST is an alist of (symbol . procedure) for this class only.
;
; FULL-ELM-INITIAL-LIST is the elements of the flattened inheritance tree.
; Initially it is #f meaning it hasn't been computed yet.
; It is computed when the class is first instantiated. During development,
-; it can be reset to #f after some module has been reloaded (requires all
-; object instantiation happens later of course).
+; it can be reset to #f after some module has been reloaded (as long as no
+; elements have been deleted/added/moved/etc., existing objects are ok).
;
-; FULL-METHOD-ALIST is an alist of the methods of the flattened inheritance
+; METHOD-CACHE is an alist of the methods of the flattened inheritance
; tree. Each element is (symbol . (parent-list-entry . method)).
; Initially it is #f meaning it hasn't been computed yet.
; It is computed when the class is first instantiated. During development,
; it can be reset to #f after some module has been reloaded (requires all
-; object instantiation happens later of course).
+; object instantiation to happen later of course).
+; FIXME: We don't yet implement the method cache.
;
; CLASS-DESCRIPTOR is the processed form of parent-name-list.
; There is an entry for the class and one for each parent (recursively):
-; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...).
-; mi? is #t if the class or any parent class has multiple inheritance.
-; This is used by the element access routines.
-; base-offset is the offset in the element vector of the baseclass (or first
-; baseclass in the mi case).
-; delta is the offset from base-offset of the class's own elements
-; (as opposed to elements in any parent class).
+; (class offset child-backpointer [parent-descriptor]).
+; offset is the offset in the element vector of the class's elements.
; child-backpointer is #f in the top level object.
; ??? child->subclass, parent->superclass?
; Initially the class-descriptor is #f meaning it hasn't been computed yet.
; it can be reset to #f after some module has been reloaded (requires all
; object instantiation to happen later of course).
;
-; An object is a vector of 2 elements: #(object-elements class-descriptor).
-; ??? Things would be simpler if objects were a pair but that makes eval'ing
-; them trickier. Vectors are nice in that they're self-evaluating, though
-; due to the self-referencing, which Guile 1.2 can't handle, apps have to
-; be careful.
-; ??? We could use smobs/records/whatever but the difference isn't big enough
-; for me to care at this point in time.
+; An object is a vector: #(object-tag class-name class-uid elm1 elm2 ...)
+; Vectors are nice in that they're self-evaluating.
+; Both class name and uid are stored here for a better developer experience.
+; It might be better to store the class-descriptor instead, but it's big and
+; vastly reduces the S/N ratio when displaying objects.
;
-; `object-elements' looks like:
-;
-; #(object-tag
-; class
-; element1
-; element2
-; ...)
-;
-; CLASS is the class the object is an instance of.
+; -----------------------------------------------------------------------------
;
; User visible procs:
;
;
; (send object method-name . args) -> result of invoking METHOD-NAME
;
-; (send-next object method-name . args) -> result of invoking next METHOD-NAME
+; (send-next object class-name method-name . args) -> result of invoking next METHOD-NAME
;
; (new class) -> instantiate CLASS
;
;
; (object-copy-top object) -> copy of OBJECT with spec'n discarded
;
-; (object-parent object parent-path) -> parent object in OBJECT via PARENT-PATH
-;
; (class? foo) -> return #t if FOO is a class
;
; (object? foo) -> return #t if FOO is an object
(define /class-tag "class")
(define /object-tag "object")
-; List of all classes.
+;; Alist of all classes.
+;; Each element is (class-name class?-object).
+;; Note that classes are consed unto the front.
(define /class-list '())
-; ??? Were written as a procedures for Hobbit's sake (I think).
+;; Table of all classes, indexed by class-uid.
+;; Note that classes are appended to the end.
+
+(define /class-table '#())
+
+;; Internal variables to mark their respective properties.
(define /object-unspecified #:unspecified)
(define /object-unbound #:unbound)
extra-text)))
/object-unspecified
)
+
(define (/object-check-name maybe-name proc-name . extra-text)
(if (not (symbol? maybe-name))
(apply /object-error
(append! (list proc-name maybe-name) extra-text)))
/object-unspecified
)
+
(define (/object-check maybe-object proc-name . extra-text)
(if (not (object? maybe-object))
(apply /object-error
/object-unspecified
)
-; X is any arbitrary Scheme data.
+;; Main routine to flag a cos error.
+;; X is any arbitrary Scheme data.
+
(define (/object-error proc-name x . text)
(error (string-append proc-name ": "
(apply string-append (map ->string text))
; Accessors.
(define (/class-name class) (vector-ref class 1))
-(define (/class-parents class) (vector-ref class 2))
-(define (/class-elements class) (vector-ref class 3))
-(define (/class-methods class) (vector-ref class 4))
-(define (/class-all-initial-values class) (vector-ref class 5))
-(define (/class-all-methods class) (vector-ref class 6))
-(define (/class-class-desc class) (vector-ref class 7))
+(define (/class-uid class) (vector-ref class 2))
+(define (/class-parent-name class) (vector-ref class 3))
+(define (/class-elements class) (vector-ref class 4))
+(define (/class-methods class) (vector-ref class 5))
+(define (/class-all-initial-values class) (vector-ref class 6))
+(define (/class-method-cache class) (vector-ref class 7))
+(define (/class-class-desc class) (vector-ref class 8))
-(define (/class-set-parents! class parents)
- (vector-set! class 2 parents)
-)
-
-(define (/class-set-elements! class elm-alist)
- (vector-set! class 3 elm-alist)
+(define (/class-set-uid! class uid)
+ (vector-set! class 2 uid)
)
(define (/class-set-methods! class method-alist)
- (vector-set! class 4 method-alist)
+ (vector-set! class 5 method-alist)
)
(define (/class-set-all-initial-values! class init-list)
- (vector-set! class 5 init-list)
+ (vector-set! class 6 init-list)
)
-(define (/class-set-all-methods! class all-meth-list)
- (vector-set! class 6 all-meth-list)
+(define (/class-set-method-cache! class all-meth-list)
+ (vector-set! class 7 all-meth-list)
)
(define (/class-set-class-desc! class parent-list)
- (vector-set! class 7 parent-list)
+ (vector-set! class 8 parent-list)
)
; Make a class.
; The new definition overrides any existing definition.
-(define (/class-make! name parents elements methods)
- (let ((class (vector /class-tag name parents elements methods #f #f #f))
+(define (/class-make! name parent-name elements)
+ (let ((class (vector /class-tag name
+ #f ;; uid filled in later
+ parent-name elements
+ '() ;; methods, none yet
+ #f #f #f))
(list-entry (assq name /class-list)))
(if list-entry
- (set-cdr! list-entry class)
- (set! /class-list (acons name class /class-list)))
+ (let ((uid (/class-uid (cdr list-entry))))
+ (/class-set-uid! class uid)
+ (set-cdr! list-entry class))
+ (let ((uid (vector-length /class-table)))
+ (/class-set-uid! class uid)
+ (set! /class-table (list->vector
+ (append (vector->list /class-table)
+ (list class))))
+ (set! /class-list (acons name class /class-list))))
class)
)
(define (class-lookup name) (assq-ref /class-list name))
-; Return a list of all direct parent classes of CLASS.
+;; Lookup a class given its uid.
+
+(define (/class-lookup-uid uid) (vector-ref /class-table uid))
+
+;; Return a list of all direct parent classes of CLASS.
+;; The list can have at most one element.
+;; this is for callers that prefer a list result.
(define (/class-parent-classes class)
- ; /class-parents returns the names, we want the actual classes.
- (let loop ((parents (/class-parents class))
- (result '()))
- (if (null? parents)
- (reverse! result)
- (let ((parent (class-lookup (car parents))))
- (if (not parent)
- ; The proc name we pass here is made up as we don't
- ; want it to be the name of an internal proc.
- (/object-error "class" (car parents) "not a class"))
- (loop (cdr parents) (cons parent result)))))
+ (if (/class-parent-name class)
+ (let ((parent (class-lookup (/class-parent-name class))))
+ (if parent
+ (list parent)
+ ;; The proc name we pass here is made up as we don't
+ ;; want it to be the name of an internal proc.
+ (/object-error "class" parent "not a class")))
+ '())
)
; Cover proc of /class-name for the outside world to use.
(/class-name class)
#f)
)
-
-; Return a boolean indicating if CLASS or any parent class has
-; multiple inheritance.
-
-(define (/class-mi? class)
- (/class-desc-mi? (/class-class-desc class))
-)
\f
; Class descriptor utilities.
; A class-descriptor is:
-; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
+; (class offset child-backpointer [parent-descriptor])
-;(define (/class-desc-make class offset bkptr parents)
-; (append (list class offset bkptr) parents)
-;)
(define (/class-desc? maybe-class-desc)
(and (pair? maybe-class-desc)
(class? (car maybe-class-desc)))
)
(define /class-desc-class car)
-(define /class-desc-mi? cadr)
-(define /class-desc-offset caddr)
-(define /class-desc-offset-base caaddr)
-(define /class-desc-offset-delta cdaddr)
-(define /class-desc-child cadddr)
-(define /class-desc-parents cddddr)
-; Note that this is an assq on the classes themselves, not their names.
-; The result is the parent's class-descriptor.
-(define /class-desc-lookup-parent assq)
+(define /class-desc-offset cadr)
+(define /class-desc-child caddr)
+(define /class-desc-parents cdddr) ;; nil or list of one element
; Compute the class descriptor of CLASS.
; OFFSET is the beginning offset in the element vector.
; We can assume the parents of CLASS have already been initialized.
;
; A class-descriptor is:
-; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
-; MI? is a boolean indicating if multiple inheritance is present.
-; BASE-OFFSET is the offset into the object vector of the baseclass's elements
-; (or first baseclass in the mi case).
-; DELTA is the offset from BASE-OFFSET of the class's own elements.
-; CHILD is the backlink to the direct child class or #f for the top class.
-; ??? Is the use of `top' backwards from traditional usage?
+; (class offset child (parent-entry))
+; CLASS is the class? data structure of the class.
+; OFFSET is the offset into the object vector of the baseclass's elements.
+; CHILD is the backlink to the direct child class or #f if no subclass.
+; PARENT-ENTRY is the class descriptor of the parent class.
(define (/class-compute-class-desc class offset child)
; Object elements are laid out using a depth first traversal of the
; inheritance tree.
- (define (compute1 class child base-offset)
-
- ; Build the result first, then build our parents so that our parents have
- ; the right value for the CHILD-BACKPOINTER field.
- ; Use a bogus value for mi? and offset for the moment.
- ; The correct values are set later.
-
- (let ((result (list class #f (cons 999 999) child))
- (mi? (> (length (/class-parents class)) 1)))
-
- ; Recurse on the parents.
- ; We use `append!' here as the location of `result' is now fixed so
- ; that our parent's child-backpointer remains stable.
-
- (append! result
- (let loop ((parents (/class-parents class))
- (parent-descs '())
- (base-offset base-offset))
- (if (null? parents)
- (reverse! parent-descs)
- (let ((parent (class-lookup (car parents))))
- (if (not parent)
- ; The proc name we pass here is made up as we don't
- ; want it to be the name of an internal proc.
- (/object-error "class" (car parents) "not a class"))
- (if (and (not mi?)
- (/class-mi? parent))
- (set! mi? #t))
- (let ((parent-desc (compute1 parent result base-offset)))
- (loop (cdr parents)
- (cons parent-desc parent-descs)
- offset))))))
-
- (list-set! result 1 mi?)
- (list-set! result 2 (cons base-offset (- offset base-offset)))
+ (define (compute1 class child)
+
+ ;; Build the result first, then build our parents so that our parents have
+ ;; the right value for the CHILD-BACKPOINTER field.
+ ;; FIXME: Can't assume append! works that way.
+ ;; Use a bogus value for offset for the moment.
+ ;; The correct value is set later.
+
+ (let ((result (list class 999 child)))
+
+ ;; Recurse on the parent.
+
+ (if (/class-parent-name class)
+ (let ((parent (class-lookup (/class-parent-name class))))
+ (if (not parent)
+ ;; The proc name we pass here is made up as we don't
+ ;; want it to be the name of an internal proc.
+ (/object-error "class" (car parents) "not a class"))
+
+ (let ((parent-desc (compute1 parent result)))
+
+ ;; We use `append!' here as the location of `result' is now fixed
+ ;; so that our parent's child-backpointer remains stable.
+ (append! result (list parent-desc)))))
+
+ (list-set! result 1 offset)
(set! offset (+ offset (length (/class-elements class))))
result))
- (compute1 class child offset)
+ (compute1 class child)
)
; Return the top level class-descriptor of CLASS-DESC.
(letrec ((dump (lambda (cd indent)
(writeln indent cep "Class: "
(/class-name (/class-desc-class cd)))
- (writeln indent cep " mi?: "
- (/class-desc-mi? cd))
- (writeln indent cep " base offset: "
- (/class-desc-offset-base cd))
- (writeln indent cep " delta: "
- (/class-desc-offset-delta cd))
+ (writeln indent cep " offset: "
+ (/class-desc-offset cd))
(writeln indent cep " child: "
(if (/class-desc-child cd)
(/class-name (/class-desc-class
(define (/object-make! class)
(/class-check-init! class)
- (vector (apply vector (append! (list /object-tag class)
- (/class-all-initial-values class)))
- (/class-class-desc class))
+ (apply vector (append! (list /object-tag
+ (/class-name class)
+ (/class-uid class))
+ (/class-all-initial-values class)))
)
; Make an object using VALUES.
; VALUES must specify all elements in the class (and parent classes).
-(define (/object-make-with-values! class class-desc values)
+(define (/object-make-with-values! class values)
(/class-check-init! class)
- (vector (apply vector (append! (list /object-tag class) values))
- class-desc)
+ (apply vector (append! (list /object-tag
+ (/class-name class)
+ (/class-uid class))
+ values))
)
; Copy an object.
-; If TOP?, the copy is of the top level object with any specialization
-; discarded.
; WARNING: A shallow copy is currently done on the elements!
-(define (/object-copy obj top?)
- (if top?
- (vector (/object-vector-copy (/object-elements obj))
- (/class-class-desc (/object-top-class obj)))
- (vector (/object-vector-copy (/object-elements obj))
- (/object-class-desc obj)))
-)
-
-; Specialize an object to be one from a parent class.
-; The result is the same object, but with a different view (confined to
-; a particular parent class).
-
-(define (/object-specialize obj class-desc)
- (vector (/object-elements obj) class-desc)
+(define (/object-copy obj)
+ (/object-vector-copy obj)
)
; Accessors.
-(define (/object-elements obj) (vector-ref obj 0))
-(define (/object-class-desc obj) (vector-ref obj 1))
-(define (/object-class obj) (/class-desc-class (/object-class-desc obj)))
-(define (/object-class-name obj) (/class-name (/object-class obj)))
-(define (/object-top-class obj) (vector-ref (/object-elements obj) 1))
+(define (/object-class-name obj) (vector-ref obj 1))
+(define (/object-class-uid obj) (vector-ref obj 2))
-(define (/object-elm-get obj class-desc elm-base-offset)
- (vector-ref (/object-elements obj)
- (+ (/class-desc-offset-base class-desc) elm-base-offset))
+(define (/object-class-desc obj)
+ (/class-class-desc (/object-class obj))
)
-(define (/object-elm-set! obj class-desc elm-base-offset new-val)
- (vector-set! (/object-elements obj)
- (+ (/class-desc-offset-base class-desc) elm-base-offset)
- new-val)
- /object-unspecified
+(define (/object-class obj)
+ (/class-lookup-uid (/object-class-uid obj))
)
-; Return a boolean indicating of OBJ has multiple-inheritance.
+(define (/object-elm-get obj elm-offset)
+ (vector-ref obj elm-offset)
+)
-(define (/object-mi? obj)
- (/class-mi? (/object-top-class obj))
+(define (/object-elm-set! obj elm-offset new-val)
+ (vector-set! obj elm-offset new-val)
+ /object-unspecified
)
; Return boolean indicating if X is an object.
(define (object? obj)
(and (vector? obj)
- (= (vector-length obj) 2)
- (vector? (vector-ref obj 0))
- (eq? /object-tag (vector-ref (vector-ref obj 0) 0))
- (/class-desc? (vector-ref obj 1)))
+ (>= (vector-length obj) 3)
+ (eq? /object-tag (vector-ref obj 0)))
)
; Return the class of an object.
; This should be fast the second time through, so don't do any
; computation until we know it's necessary.
- (if (not (/class-all-initial-values class))
+ (if (/class-all-initial-values class)
+
+ #t ;; nothing to do
(begin
(/class-set-all-initial-values! class inits)))
; Next pass initializes the class's class-descriptor.
- ; Object elements begin at offset 2 in the element vector.
+ ; Object elements begin at offset 3 in the element vector.
(/class-set-class-desc! class
- (/class-compute-class-desc class 2 #f))
+ (/class-compute-class-desc class 3 #f))
))
/object-unspecified
; Make a class.
;
-; PARENTS is a list of names of parent classes. The parents need not
-; exist yet, though they must exist when the class is first instantiated.
+; PARENTS is the name of parent class as a list, i.e. () or (<parent>).
+; It's a list just in case multiple-inheritance is added one day.
+; The parent need not exist yet, though it must exist when the class
+; is first instantiated.
; ELMS is a either a list of either element names or name/value pairs.
; Elements without initial values are marked as "unbound".
; METHODS is an initial alist of methods. More methods can be added with
; method-make!.
(define (class-make name parents elms methods)
+ (if (> (length parents) 1)
+ (/object-error 'class-make parents "multiple-inheritance is not supported"))
+ (if (> (length methods) 0)
+ (/object-error 'class-make methods "methods specified with class"))
+
(let ((elm-list #f))
; Mark elements without initial values as unbound, and
; compute indices into the element vector (relative to the class's
; offset).
- ; Elements are recorded as (symbol initial-value private? . vector-index)
- ; FIXME: For now all elements are marked as "public".
+ ; Elements are recorded as (symbol initial-value . vector-index)
(let loop ((elm-list-tmp '()) (index 0) (elms elms))
(if (null? elms)
(set! elm-list (reverse! elm-list-tmp)) ; done
(if (pair? (car elms))
(loop (acons (caar elms)
- (cons (cdar elms) (cons #f index))
+ (cons (cdar elms) index)
elm-list-tmp)
(+ index 1)
(cdr elms))
(loop (acons (car elms)
- (cons /object-unbound (cons #f index))
+ (cons /object-unbound index)
elm-list-tmp)
(+ index 1)
(cdr elms)))))
- (let ((result (/class-make! name parents elm-list methods)))
+ (let ((result (/class-make! name
+ (if (null? parents) #f (car parents))
+ elm-list)))
; Create the standard `make!' method.
; The caller can override afterwards if desired.
(let ((self (car args)))
; Ensure exactly all of the elements are provided.
(if (not (= (length args)
- (- (vector-length (/object-elements self)) 1)))
+ (- (vector-length self) 2)))
(/object-error "make!" "" "wrong number of arguments to method `make!'"))
- (/object-make-with-values! (/object-top-class self)
- (/object-class-desc self)
+ (/object-make-with-values! (/object-class self)
(cdr args)))))
result))
(define (object-copy obj)
(/object-check obj "object-copy")
- (/object-copy obj #f)
+ (/object-copy obj)
)
; Make a copy of OBJ.
; This makes a copy of top level object, with any specialization discarded.
; WARNING: A shallow copy is done on the elements!
+; FIXME: Delete, specialization gone.
(define (object-copy-top obj)
(/object-check obj "object-copy-top")
- (/object-copy obj #t)
+ (/object-copy obj)
)
; Utility to define a standard `make!' method.
(define (/class-subclass? base-name x)
(if (eq? base-name (/class-name x))
#t
- (let loop ((parents (/class-parents x)))
- (if (null? parents)
- #f
- (if (/class-subclass? base-name (class-lookup (car parents)))
- #t
- (loop (cdr parents))))))
+ (let ((parent-name (/class-parent-name x)))
+ (if parent-name
+ (/class-subclass? base-name (class-lookup parent-name))
+ #f)))
)
; Return #t if OBJECT is an instance of CLASS.
; Element operations.
; Lookup an element in a class-desc.
-; The result is (class-desc . (private? . elm-offset)) or #f if not found.
-; ??? We could define accessors of the result but knowledge of its format
-; is restricted to this section of the source.
+; The result is elm-index or #f if not found.
(define (/class-lookup-element class-desc elm-name)
(let* ((class (/class-desc-class class-desc))
(elm (assq elm-name (/class-elements class))))
(if elm
- (cons class-desc (cddr elm))
- (let loop ((parents (/class-desc-parents class-desc)))
+ (+ (cddr elm) ;; elm is (name init-value . index)
+ (/class-desc-offset class-desc))
+ (let ((parents (/class-desc-parents class-desc)))
(if (null? parents)
#f
- (let ((elm (/class-lookup-element (car parents) elm-name)))
- (if elm
- elm
- (loop (cdr parents)))))
- ))
- )
+ (/class-lookup-element (car parents) elm-name)))))
)
-; Given the result of /class-lookup-element, return the element's delta
-; from base-offset.
-
-(define (/elm-delta index)
- (+ (/class-desc-offset-delta (car index))
- (cddr index))
-)
+; Return a boolean indicating if ELM-NAME is bound in OBJ.
-; Return a boolean indicating if ELM is bound in OBJ.
-
-(define (elm-bound? obj elm)
+(define (elm-bound? obj elm-name)
(/object-check obj "elm-bound?")
- (let* ((index (/class-lookup-element (/object-class-desc obj) elm))
- (val (/object-elm-get obj (car index) (/elm-delta index))))
- (not (eq? val /object-unbound)))
+ (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
+ (if index
+ (not (eq? (/object-elm-get obj index) /object-unbound))
+ (/object-error "elm-get" self "element not present: " elm-name)))
)
; Subroutine of elm-get.
-(define (/elm-make-method-getter self name)
+(define (/elm-make-method-getter self elm-name)
(/object-check self "elm-get")
- (let ((index (/class-lookup-element (/object-class-desc self) name)))
+ (let ((index (/class-lookup-element (/object-class-desc self) elm-name)))
(if index
(procedure->memoizing-macro
(lambda (exp env)
`(lambda (obj)
- (/object-elm-get obj (/object-class-desc obj)
- ,(/elm-delta index)))))
- (/object-error "elm-get" self "element not present: " name)))
+ (/object-elm-get obj ,index))))
+ (/object-error "elm-get" self "element not present: " elm-name)))
)
; Get an element from an object.
; What this does is turn
; (elm-get self 'foo)
; into
-; ((-elm-make-method-get self 'foo) self)
-; Note the extra set of parens. -elm-make-method-get then does the lookup of
+; ((/elm-make-method-get self 'foo) self)
+; Note the extra set of parens. /elm-make-method-get then does the lookup of
; foo and returns a memoizing macro that returns the code to perform the
; operation with O(1). Cute, but I'm hoping there's an easier/better way.
-(defmacro elm-get (self name)
+(defmacro elm-get (self elm-name)
(if (eq? self 'self)
- `(((/elm-make-method-getter ,self ,name)) ,self)
- `(elm-xget ,self ,name))
+ `(((/elm-make-method-getter ,self ,elm-name)) ,self)
+ `(elm-xget ,self ,elm-name))
)
; Subroutine of elm-set!.
-(define (/elm-make-method-setter self name)
+(define (/elm-make-method-setter self elm-name)
(/object-check self "elm-set!")
- (let ((index (/class-lookup-element (/object-class-desc self) name)))
+ (let ((index (/class-lookup-element (/object-class-desc self) elm-name)))
(if index
(procedure->memoizing-macro
(lambda (exp env)
`(lambda (obj new-val)
- (/object-elm-set! obj (/object-class-desc obj)
- ,(/elm-delta index) new-val))))
- (/object-error "elm-set!" self "element not present: " name)))
+ (/object-elm-set! obj ,index new-val))))
+ (/object-error "elm-set!" self "element not present: " elm-name)))
)
; Set an element in an object.
; This can only be used by methods.
; See the comments for `elm-get'!
-(defmacro elm-set! (self name new-val)
+(defmacro elm-set! (self elm-name new-val)
(if (eq? self 'self)
- `(((/elm-make-method-setter ,self ,name)) ,self ,new-val)
- `(elm-xset! ,self ,name ,new-val))
+ `(((/elm-make-method-setter ,self ,elm-name)) ,self ,new-val)
+ `(elm-xset! ,self ,elm-name ,new-val))
)
; Get an element from an object.
; This is for invoking from outside a method, and without having to
; use elm-make-getter. It should be used sparingly.
-(define (elm-xget obj name)
+(define (elm-xget obj elm-name)
(/object-check obj "elm-xget")
- (let ((index (/class-lookup-element (/object-class-desc obj) name)))
- ; FIXME: check private?
+ (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
(if index
- (/object-elm-get obj (car index) (/elm-delta index))
- (/object-error "elm-xget" obj "element not present: " name)))
+ (/object-elm-get obj index)
+ (/object-error "elm-xget" obj "element not present: " elm-name)))
)
; Set an element in an object.
; This is for invoking from outside a method, and without having to
; use elm-make-setter. It should be used sparingly.
-(define (elm-xset! obj name new-val)
+(define (elm-xset! obj elm-name new-val)
(/object-check obj "elm-xset!")
- (let ((index (/class-lookup-element (/object-class-desc obj) name)))
- ; FIXME: check private?
+ (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
(if index
- (/object-elm-set! obj (car index) (/elm-delta index) new-val)
- (/object-error "elm-xset!" obj "element not present: " name)))
+ (/object-elm-set! obj index new-val)
+ (/object-error "elm-xset!" obj "element not present: " elm-name)))
)
-; Return a boolean indicating if object OBJ has element NAME.
+; Return a boolean indicating if object OBJ has element ELM-NAME.
-(define (elm-present? obj name)
+(define (elm-present? obj elm-name)
(/object-check obj "elm-present?")
- (->bool (/class-lookup-element (/object-class-desc obj) name))
+ (->bool (/class-lookup-element (/object-class-desc obj) elm-name))
)
-; Return lambda to get element NAME in CLASS.
-; FIXME: validate name.
+; Return lambda to get element ELM-NAME in CLASS.
+; FIXME: validate elm-name.
-(define (elm-make-getter class name)
+(define (elm-make-getter class elm-name)
(/class-check class "elm-make-getter")
; We use delay here as we can't assume parent classes have been
; initialized yet.
(let ((fast-index (delay (/class-lookup-element
- (/class-class-desc class) name))))
+ (/class-class-desc class) elm-name))))
(lambda (obj)
- ; ??? Should be able to use fast-index in mi case.
- ; ??? Need to involve CLASS in lookup.
- (let ((index (if (/object-mi? obj)
- (/class-lookup-element (/object-class-desc obj) name)
- (force fast-index))))
- (/object-elm-get obj (car index) (/elm-delta index)))))
+ (let ((index (force fast-index)))
+ (/object-elm-get obj index))))
)
-; Return lambda to set element NAME in CLASS.
-; FIXME: validate name.
+; Return lambda to set element ELM-NAME in CLASS.
+; FIXME: validate elm-name.
-(define (elm-make-setter class name)
+(define (elm-make-setter class elm-name)
(/class-check class "elm-make-setter")
; We use delay here as we can't assume parent classes have been
; initialized yet.
(let ((fast-index (delay (/class-lookup-element
- (/class-class-desc class) name))))
+ (/class-class-desc class) elm-name))))
(lambda (obj newval)
- ; ??? Should be able to use fast-index in mi case.
- ; ??? Need to involve CLASS in lookup.
- (let ((index (if (/object-mi? obj)
- (/class-lookup-element (/object-class-desc obj) name)
- (force fast-index))))
- (/object-elm-set! obj (car index) (/elm-delta index) newval))))
-)
-
-; Return a list of all elements in OBJ.
-
-(define (elm-list obj)
- (cddr (vector->list (/object-elements obj)))
+ (let ((index (force fast-index)))
+ (/object-elm-set! obj index newval))))
)
\f
; Method operations.
; Lookup the next method in a class.
-; This means begin the search in the parents.
+; This means begin the search in the parent.
(define (/method-lookup-next class-desc method-name)
- (let loop ((parents (/class-desc-parents class-desc)))
- (if (null? parents)
+ (let ((parent-descs (/class-desc-parents class-desc)))
+ (if (null? parent-descs)
#f
- (let ((meth (/method-lookup (car parents) method-name)))
- (if meth
- meth
- (loop (cdr parents))))))
+ (let ((parent-desc (car parent-descs)))
+ (/method-lookup parent-desc method-name))))
)
; Lookup a method in a class.
; The result is (class-desc . method). If the method is found in a parent
; class, the associated parent class descriptor is returned.
-;
-; FIXME: We don't yet implement the method cache.
(define (/method-lookup class-desc method-name)
(if /object-verbose?
)
; Add a method to a class.
-; FIXME: ensure method-name is a symbol
(define (method-make! class method-name method)
(/class-check class "method-make!")
+ (/object-check-name method-name "method-make!" "method-name must be a symbol")
(if (not (procedure? method))
(/object-error "method-make!" method "method must be a procedure"))
(/class-set-methods! class (acons method-name method
(define (send obj method-name . args)
(/object-check obj "send")
- (/object-check-name method-name "send" "not a method name")
(if /object-verbose? (/object-method-notify obj method-name ""))
(let ((class-desc.meth (/method-lookup (/object-class-desc obj)
method-name)))
(if class-desc.meth
(apply (cdr class-desc.meth)
- (cons (/object-specialize obj (car class-desc.meth))
- args))
+ (cons obj args))
(/object-error "send" obj "method not supported: " method-name)))
)
; Invoke the next method named METHOD-NAME in the heirarchy of OBJ.
; i.e. the method that would have been invoked if the calling method
; didn't exist.
+; CLASS-NAME is the class of the invoking method.
+; It is present to simplify things: otherwise we have to either include in
+; objects the notion a current class or specialization, or include the class
+; as an argument to methods.
; This may only be called by a method.
-; ??? Ideally we shouldn't need the METHOD-NAME argument. It could be
-; removed with a bit of effort, but is it worth it?
+; ??? Ideally we shouldn't need either CLASS-NAME or METHOD-NAME arguments.
+; They could be removed with a bit of effort, but is it worth it?
+; One possibility is if method-make! was a macro, then maybe send-next could
+; work with method-make! and get the values from it.
-(define (send-next obj method-name . args)
+(define (send-next obj class-name method-name . args)
(/object-check obj "send-next")
- (/object-check-name method-name "send-next" "not a method name")
(if /object-verbose? (/object-method-notify obj method-name "next "))
- (let ((class-desc.meth (/method-lookup-next (/object-class-desc obj)
- method-name)))
+ (let* ((class (class-lookup class-name)) ;; FIXME: slow
+ (class-desc.meth (/method-lookup-next (/class-class-desc class)
+ method-name)))
(if class-desc.meth
(apply (cdr class-desc.meth)
- (cons (/object-specialize obj (car class-desc.meth))
- args))
+ (cons obj args))
(/object-error "send-next" obj "method not supported: " method-name)))
)
\f
-; Parent operations.
-
-; Subroutine of `parent' to lookup a (potentially nested) parent class.
-; The result is the parent's class-descriptor or #f if not found.
-
-(define (/class-parent class-desc parent)
- (let* ((parent-descs (/class-desc-parents class-desc))
- (desc (/class-desc-lookup-parent parent parent-descs)))
- (if desc
- desc
- (let loop ((parents parent-descs))
- (if (null? parents)
- #f
- (let ((desc (/class-parent (car parents) parent)))
- (if desc
- desc
- (loop (cdr parents))))))))
-)
-
-; Subroutine of `parent' to lookup a parent via a path.
-; PARENT-PATH, a list, is the exact path to the parent class.
-; The result is the parent's class-descriptor or #f if not found.
-; For completeness' sake, if PARENT-PATH is empty, CLASS-DESC is returned.
-
-(define (/class-parent-via-path class-desc parent-path)
- (if (null? parent-path)
- class-desc
- (let ((desc (/class-desc-lookup-parent (car parent-path)
- (/class-desc-parents class-desc))))
- (if desc
- (if (null? (cdr parent-path))
- desc
- (/class-parent-via-path (car desc) (cdr parent-path)))
- #f)))
-)
-
-; Lookup a parent class of object OBJ.
-; CLASS is either a class or a list of classes.
-; If CLASS is a list, it is a (possibly empty) "path" to the parent.
-; Otherwise it is any parent and is searched for breadth-first.
-; ??? Methinks this should be depth-first.
-; The result is OBJ, specialized to the found parent.
-
-(define (object-parent obj class)
- (/object-check obj "object-parent")
- (cond ((class? class) #t)
- ((list? class) (for-each (lambda (class) (/class-check class
- "object-parent"))
- class))
- (else (/object-error "object-parent" class "invalid parent path")))
-
- ; Hobbit generates C code that passes the function
- ; /class-parent-via-path or /class-parent, not the appropriate
- ; SCM object.
-; (let ((result ((if (or (null? class) (pair? class))
-; /class-parent-via-path
-; /class-parent)
-; obj class)))
- ; So it's rewritten like this.
- (let ((result (if (class? class)
- (/class-parent (/object-class-desc obj) class)
- (/class-parent-via-path (/object-class-desc obj) class))))
- (if result
- (/object-specialize obj result)
- (/object-error "object-parent" obj "parent not present")))
- ; FIXME: should print path in error message.
-)
-
-; Make PARENT-NAME a parent of CLASS, cons'd unto the front of the search
-; order. This is used to add a parent class to a class after it has already
-; been created. Obviously this isn't something one does willy-nilly.
-; The parent is added to the front of the current parent list (affects
-; method lookup).
-
-(define (class-cons-parent! class parent-name)
- (/class-check class "class-cons-parent!")
- (/object-check-name parent-name "class-cons-parent!" "not a class name")
- (/class-set-parents! class (cons parent-name (/class-parents class)))
- /object-unspecified
-)
-
-; Make PARENT-NAME a parent of CLASS, cons'd unto the end of the search order.
-; This is used to add a parent class to a class after it has already been
-; created. Obviously this isn't something one does willy-nilly.
-; The parent is added to the end of the current parent list (affects
-; method lookup).
-
-(define (class-append-parent! class parent-name)
- (/class-check class "class-append-parent!")
- (/object-check-name parent-name "class-append-parent!" "not a class name")
- (/class-set-parents! obj (append (/class-parents obj) (list parent-name)))
- /object-unspecified
-)
-\f
; Miscellaneous publically accessible utilities.
; Reset the object system (delete all classes).
(define (object-reset!)
- (set! /class-list '())
+ (set! /class-list (list))
+ (set! /class-table (vector))
/object-unspecified
)
; We need a fast vector copy operation.
; If `vector-copy' doesn't exist (which is assumed to be the fast one),
; provide a simple version.
-; FIXME: Need deep copier instead.
(if (defined? 'vector-copy)
(define /object-vector-copy vector-copy)
OSDN Git Service
