Subversion Repositories scarts

; Cgen's Object System.

; Copyright (C) 2000, 2009 Red Hat, Inc.

; 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.

;

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

;

; PARENT-NAME-LIST is a list of the names of parent classes (the inheritance

; tree).

;

; ELM-ALIST is an alist of (symbol private? vector-index . 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.

;

; METHOD-ALIST is an alist of (symbol . (virtual? . 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).

;

; FULL-METHOD-ALIST 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).

;

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

; 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 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 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.

;

; `object-elements' looks like:

;

; #(object-tag

;   class

;   element1

;   element2

;   ...)

;

; CLASS is the class the object is an instance of.

;

; User visible procs:

;

; (class-make name parents elements methods) -> class

;

; Create a class.  The result is then passed back by procedures requiring

; a class argument.  Note however that PARENTS is a list of class names,

; not the class data type.  This allows reloading the definition of a

; parent class without having to reload any subclasses.  To implement this

; classes are recorded internally, and `object-init!' must be called if any

; class has been redefined.

;

; (class-list) -> list of all defined classes

;

; (class-name class) -> name of CLASS

;

; (class-lookup class-name) -> class

;

; (class-instance? class object) -> #t if OBJECT is an instance of CLASS

;

; (object-class object) -> class of OBJECT

;

; (object-class-name object) -> class name of OBJECT

;

; (send object method-name . args) -> result of invoking METHOD-NAME

;

; (send-next object method-name . args) -> result of invoking next METHOD-NAME

;

; (new class) -> instantiate CLASS

;

; The object is initialized with values specified when CLASS

; (and its parent classes) was defined.

;

; (vmake class . args) -> instantiate class and initialize it with 'vmake!

;

; This is shorthand for (send (new class) 'vmake! args).

; ARGS is a list of option names and arguments (a la CLOS).

; ??? Not implemented yet.

;

; (method-vmake! object . args) -> modify OBJECT from ARGS

;

; This is the standard 'vmake! method, available for use by user-written

; 'vmake! methods.

; ??? Not implemented yet.

;

; (make class . args) -> instantiate CLASS and initialize it with 'make!

;

; This is shorthand for (send (new class) 'make! arg1 ...).

; This is a positional form of `new'.

;

; (method-make-make! class elm1-name elm2-name ...) -> unspecified

;

; Create a 'make! method that sets the specified elements.

;

; (object-copy object) -> copy of OBJ

;

; ??? Whether to discard the parent or keep it and retain specialization

; is undecided.

;

; (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

;

; (method-make! class name lambda) -> unspecified

;

; Add method NAME to CLASS.

;

; (method-make-virtual! class name lambda) -> unspecified

;

; Add virtual method NAME to CLASS.

;

; (method-make-forward! class elm-name methods) -> unspecified

;

; Add METHODS to CLASS that pass the "message" onto the object in element

; ELM-NAME.

;

; (method-make-virtual-forward! class elm-name methods) -> unspecified

;

; Add virtual METHODS to CLASS that pass the "message" onto the object in

; element ELM-NAME.

;

; (elm-get object elm-name) -> value of element ELM-NAME in OBJ

;

; Can only be used in methods.

;

; (elm-set! object elm-name new-value) -> unspecified

;

; Set element ELM-NAME in OBJECT to NEW-VALUE.

; Can only be used in methods.

;

; (elm-make-getter class elm-name) -> lambda

;

; Return lambda to get the value of ELM-NAME in CLASS.

;

; (elm-make-setter class elm-name) -> lambda

;

; Return lambda to set the value of ELM-NAME in CLASS.

;

; Conventions used in this file:

; - procs/vars internal to this file are prefixed with "-"

;   [Of course this could all be put in a module; later if ever since

;   once Guile has its own official object system we'll convert.  Note that

;   it currently does not.]

; - except for a few exceptions, public procs begin with one of

;   class-, object-, elm-, method-.

;   The exceptions are make, new, parent, send.

; ??? Were written as a procedures for Hobbit's sake (I think).

; Associative list of classes to be traced.

; Associative list of messages to be traced.

; Cover fn to set verbosity.

"not a class""not an object"; X is any arbitrary Scheme data.

": "" (class: "", name: """")"""""; Low level class operations.

; Return boolean indicating if X is a class.

; Make a class.

; Lookup a class given its name.

; Return a list of all direct parent classes of CLASS.

; The proc name we pass here is made up as we don't

"class""not a class"; Cover proc of -class-name for the outside world to use.

; We could issue an error here, but to be consistent with object-class-name

; Return a boolean indicating if CLASS or any parent class has

; Class descriptor utilities.

; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)

;   (append (list class offset bkptr) parents)

;)

; Note that this is an assq on the classes themselves, not their names.

; Compute the class descriptor of CLASS.

; 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?

; OFFSET must be global to the calculation because it is continually

; incremented as we recurse down through the hierarchy (actually, as we

; traverse back up).  At any point in time it is the offset from the start

; of the element vector of the next class's elements.

; Object elements are laid out using a depth first traversal of the

; inheritance tree.

; 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.

; We use `append!' here as the location of `result' is now fixed so

; that our parent's child-backpointer remains stable.

; The proc name we pass here is made up as we don't

; want it to be the name of an internal proc.

"class""not a class"; Return the top level class-descriptor of CLASS-DESC.

; Pretty print a class descriptor.

"Class: ""  mi?:         ""  base offset: ""  delta:       ""  child:       ""-top-""Top level class: "; Low level object utilities.

; Make an object.

; All elements get initial (or unbound) values.

; Make an object using VALUES.

; VALUES must specify all elements in the class (and parent classes).

; 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!

; The result is the same object, but with a different view (confined to

; Accessors.

; Return boolean indicating if X is an object.

; Return the class of an object.

"object-class"; Cover proc of -object-class-name for the outside world to use.

; Class operations.

; The result does not include parent classes.

; Initialize class if not already done.

; FIXME: Need circularity check.  Later.

; This should be fast the second time through, so don't do any

; computation until we know it's necessary.

; First pass ensures all parents are initialized.

; Next pass initializes the initial value list.

; Object elements begin at offset 2 in the element vector.

; Make a class.

;

; exist yet, though they 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".

; method-make!.

; Mark elements without initial values as unbound, and

; compute indices into the element vector (relative to the class's

; Elements are recorded as (symbol initial-value private? . vector-index)

; FIXME: For now all elements are marked as "public".

; done

; The caller can override afterwards if desired.

; Note that if there are any parent classes then we don't know the names

; of all of the elements yet, that is only known after the class has been

; This method won't be called until that happens though so we're safe.

; This is written without knowledge of the names, it just initializes

; all elements.

"make!""""wrong number of arguments to method `make!'"; Create an object of a class CLASS.

"new""Instantiating class "".\n"; Make a copy of OBJ.

"object-copy"; 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!

"object-copy-top"; Utility to define a standard `make!' method.

; A standard make! method is one in which all it does is initialize

; fields from args.

; The "standard" way to invoke `make!' is (send (new class) 'make! ...).

; This puts all that in a cover function.

; Return #t if OBJECT is an instance of CLASS.

; This does not signal an error if OBJECT is not an object as this is

"class-instance?"; Element operations.

; The result is (class-desc . (private? . elm-offset)) or #f if not found.

; is restricted to this section of the source.

; Given the result of -class-lookup-element, return the element's delta

; from base-offset.

; Return a boolean indicating if ELM is bound in OBJ.

"elm-bound?"; Subroutine of elm-get.

"elm-get""elm-get""element not present: "; Get an element from an object.

; If OBJ is `self' then the caller is required to be a method and we emit

; memoized code.  Otherwise we do things the slow way.

; ??? There must be a better way.

; What this does is turn

; (elm-get self 'foo)

; into

; ((-elm-make-method-get self 'foo) self)

; 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.

; Subroutine of elm-set!.

"elm-set!""elm-set!""element not present: "; Set an element in an object.

; See the comments for `elm-get'!

; 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.

"elm-xget"; FIXME: check private?

; This is for invoking from outside a method, and without having to

; use elm-make-setter.  It should be used sparingly.

"elm-xset!""element not present: "; Return a boolean indicating if object OBJ has element NAME.

"elm-present?"; Return lambda to get element NAME in CLASS.

; FIXME: validate name.

; initialized yet.

; ??? Should be able to use fast-index in mi case.

; ??? Need to involve CLASS in lookup.

; FIXME: validate name.

"elm-make-setter"; We use delay here as we can't assume parent classes have been

; initialized yet.

; ??? Should be able to use fast-index in mi case.

; ??? Need to involve CLASS in lookup.

; Return a list of all elements in OBJ.

; Method operations.

; Lookup the next method in a class.

; This means begin the search in the parents.

; ??? What should this do for virtual methods.  At present we treat them as

; non-virtual.

; 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.  If the method is

; a virtual method, the appropriate subclass's class descriptor is returned.

; VIRTUAL? is #t if virtual methods are to be treated as such.

; Otherwise they're treated as normal methods.

; FIXME: We don't yet implement the method cache.

"Looking up method "" in "".\n"; virtual?

; Traverse back up the inheritance chain looking for overriding

; methods.  The closest one to the top is the one to use.

"Looking up virtual method "" in "".\n"; Method found, update goal object and method.

; Method not found at this level.

; Went all the way up to the top.

; Non-virtual, done.

; Method not found, search parents.

; Return a boolean indicating if object OBJ has method NAME.

"method-present?"; Return method NAME of CLASS or #f if not present.

; ??? Assumes CLASS has been initialized.

; FIXME: ensure method-name is a symbol

; FIXME: ensure method-name is a symbol

"method-make-virtual!""method-make-virtual!""method must be a procedure"; Utility to create "forwarding" methods.

; METHODS are forwarded to class member ELM-NAME, assumed to be an object.

; The created methods take a variable number of arguments.

; Argument length checking will be done by the receiving method.

; FIXME: ensure elm-name is a symbol

; FIXME: ensure elm-name is a symbol

"Sending "" to"" object """""" class "".\n"; Invoke a method in an object.

; When the method is invoked, the (possible parent class) object in which the

; method is found is passed to the method.

; ??? The word `send' comes from "sending messages".  Perhaps should pick

"send""send""not a method name""""send""method not supported: "; 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

; 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?

; Subroutine of `parent' to lookup a (potentially nested) parent class.

; The result is the parent's class-descriptor or #f if not found.

; 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.

; 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.

"object-parent""object-parent""object-parent""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)

; So it's rewritten like this.

"object-parent""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

; The parent is added to the front of the current parent list (affects

; method lookup).

; This is used to add a parent class to a class after it has already been

; The parent is added to the end of the current parent list (affects

; method lookup).

"class-append-parent!""class-append-parent!""not a class name"; Miscellaneous publically accessible utilities.

; Reset the object system (delete all classes).

; Call once to initialize the object system.

; instantiated.  This usually happens during development only.

; Utility to map over a class and all its parent classes, recursively.

; Return class tree of a class or object.

"class-tree""not a class or object"; Return names of each alist.

; Return complete layout of class-or-object.

"class-layout""not a class or object"; Like assq but based on the `name' element.

; WARNING: Slow.

; Like memq but based on the `name' element.

; WARNING: Slow.

; Misc. internal utilities.

; 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.

; Profiling support