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.
"class""object"; List of all classes.
; ??? Were written as a procedures for Hobbit's sake (I think).
; Associative list of classes to be traced.
; Associative list of elements to be traced.
; Associative list of messages to be traced.
; True if error messages are verbose and debugging messages are printed.
; Cover fn to set verbosity.
; Signal error if not class/object.
"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.
; Accessors.
; Make a class.
; The new definition overrides any existing definition.
; Lookup a class given its name.
; The result is the class or #f if not found.
; Return a list of all direct parent classes of CLASS.
; -class-parents returns the names, we want the actual classes.
; 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"; Cover proc of -class-name for the outside world to use.
; The result is the name of the class or #f if CLASS is not a class.
; We could issue an error here, but to be consistent with object-class-name
; we don't.
; Return a boolean indicating if CLASS or any parent class has
; multiple inheritance.
; Class descriptor utilities.
; A class-descriptor is:
; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
;(define (-class-desc-make class offset bkptr parents)
;   (append (list class offset bkptr) parents)
;)
; Note that this is an assq on the classes themselves, not their names.
; The result is the parent's class-descriptor.
; 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?
; 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.
; 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.
; 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!
; 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).
; Accessors.
; Return a boolean indicating of OBJ has multiple-inheritance.
; 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.
; The result is the name of the class or #f if OBJ is not an object.
; Class operations.
; Return the list of initial values for CLASS.
; 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.
; Next pass initializes the class's class-descriptor.
; Object elements begin at offset 2 in the element vector.
; 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.
; 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!.
; 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".
; done
; Create the standard `make!' method.
; 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
; initialized which only happens when the class is first instantiated.
; 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.
; Ensure exactly all of the elements are provided.
"make!""""wrong number of arguments to method `make!'"; Create an object of a class CLASS.
"new""Instantiating class "".\n"; Make a copy of OBJ.
; WARNING: A shallow copy is done on the elements!
"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 class X is a subclass of BASE-NAME.
; Return #t if OBJECT is an instance of CLASS.
; This does not signal an error if OBJECT is not an object as this is
; intended to be used in class predicates.
"class-instance?"; 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.
; 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)
; 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.
; Subroutine of elm-set!.
"elm-set!""elm-set!""element not present: "; Set an element in an object.
; This can only be used by methods.
; 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?
"elm-xget""element not present: "; 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.
"elm-xset!"; FIXME: check private?
"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.
"elm-make-getter"; 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 lambda to set element NAME in CLASS.
; 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.
"method-proc"; Add a method to a class.
; FIXME: ensure method-name is a symbol
"method-make!""method-make!""method must be a procedure"; Add a virtual method to a class.
; 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
; Same as method-make-forward! but creates virtual methods.
; FIXME: ensure elm-name is a symbol
; Utility of send, send-next.
"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
; a better name for this operation.
"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
; didn't exist.
; 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?
"send-next""send-next""not a method name""next ""send-next""method not supported: "; 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.
; 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)
;		   obj class)))
; 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
; 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).
"class-cons-parent!""class-cons-parent!""not a class name"; 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).
"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.
; Only necessary if classes have been modified after objects have been
; instantiated.  This usually happens during development only.
; Return list of all classes.
; 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