diff options
Diffstat (limited to 'cgen/cos.scm')
| -rw-r--r-- | cgen/cos.scm | 1336 |
1 files changed, 1336 insertions, 0 deletions
diff --git a/cgen/cos.scm b/cgen/cos.scm new file mode 100644 index 00000000000..7bb2a6e8630 --- /dev/null +++ b/cgen/cos.scm @@ -0,0 +1,1336 @@ +; Cgen's Object System. +; Copyright (C) 2000 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. + +(define -class-tag "class") +(define -object-tag "object") + +; List of all classes. + +(define -class-list ()) + +; ??? Were written as a procedures for Hobbit's sake (I think). +(define -object-unspecified #:unspecified) +(define -object-unbound #:unbound) + +; Associative list of classes to be traced. + +(define -object-debug-classes #f) + +; Associative list of elements to be traced. + +(define -object-debug-elements #f) + +; Associative list of messages to be traced. + +(define -object-debug-methods #f) + +; True if error messages are verbose and debugging messages are printed. + +(define -object-verbose? #f) + +; Cover fn to set verbosity. + +(define (object-set-verbose! verbose?) + (set! -object-verbose? verbose?) +) + +; Signal error if not class/object. + +(define (-class-check maybe-class proc-name . extra-text) + (if (not (class? maybe-class)) + (apply -object-error + (append! (list proc-name maybe-class "not a class") + 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 + (append! (list proc-name maybe-object "not an object") + extra-text))) + -object-unspecified +) + +; X is any arbitrary Scheme data. +(define (-object-error proc-name x . text) + (error (string-append proc-name ": " (apply string-append text) + (if (object? x) + (string-append + " (class: " (-object-class-name x) + (if (method-present? x 'get-name) + (string-append ", name: " + (send x 'get-name)) + "") + ")") + "") + "") + x) +) + +; Low level class operations. + +; Return boolean indicating if X is a class. + +(define (class? class) + (and (vector? class) (eq? -class-tag (vector-ref class 0))) +) + +; 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-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-methods! class method-alist) + (vector-set! class 4 method-alist) +) + +(define (-class-set-all-initial-values! class init-list) + (vector-set! class 5 init-list) +) + +(define (-class-set-all-methods! class all-meth-list) + (vector-set! class 6 all-meth-list) +) + +(define (-class-set-class-desc! class parent-list) + (vector-set! class 7 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)) + (list-entry (assq name -class-list))) + (if list-entry + (set-cdr! list-entry class) + (set! -class-list (acons name class -class-list))) + class) +) + +; Lookup a class given its name. +; The result is the class or #f if not found. + +(define (class-lookup name) (assq-ref -class-list name)) + +; Return a list of all direct parent classes of CLASS. + +(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))))) +) + +; 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. + +(define (class-name class) + (if (class? class) + (-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)) +) + +; 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) +;) +(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) + +; 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? + +(define (-class-compute-class-desc class offset child) + + ; 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. + + (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))) + (set! offset (+ offset (length (-class-elements class)))) + result)) + + (compute1 class child offset) +) + +; Return the top level class-descriptor of CLASS-DESC. + +(define (-class-desc-top class-desc) + (if (-class-desc-child class-desc) + (-class-desc-top (-class-desc-child class-desc)) + class-desc) +) + +; Pretty print a class descriptor. + +(define (class-desc-dump class-desc) + (let* ((cep (current-error-port)) + (top-desc (-class-desc-top class-desc)) + (spaces (lambda (n port) + (display (make-string n #\space) port))) + (writeln (lambda (indent port . args) + (spaces indent port) + (for-each (lambda (arg) (display arg port)) + args) + (newline port))) + ) + (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 " child: " + (if (-class-desc-child cd) + (-class-name (-class-desc-class + (-class-desc-child cd))) + "-top-")) + (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4))) + (-class-desc-parents cd)) + ))) + (display "Top level class: " cep) + (display (-class-name (-class-desc-class top-desc)) cep) + (newline cep) + (dump class-desc 0) + )) +) + +; Low level object utilities. + +; Make an object. +; All elements get initial (or unbound) values. + +(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)) +) + +; 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) + (-class-check-init! class) + (vector (apply vector (append! (list -object-tag class) values)) + class-desc) +) + +; 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) +) + +; 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-elm-get obj class-desc elm-base-offset) + (vector-ref (-object-elements obj) + (+ (-class-desc-offset-base class-desc) elm-base-offset)) +) + +(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 +) + +; Return a boolean indicating of OBJ has multiple-inheritance. + +(define (-object-mi? obj) + (-class-mi? (-object-top-class obj)) +) + +; 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))) +) + +; Return the class of an object. + +(define (object-class obj) + (-object-check obj "object-class") + (-object-class obj) +) + +; 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. + +(define (object-class-name obj) + (if (object? obj) + (-object-class-name obj) + #f) +) + +; Class operations. + +; Return the list of initial values for CLASS. +; The result does not include parent classes. + +(define (-class-my-initial-values class) + (map cadr (-class-elements class)) +) + +; Initialize class if not already done. +; FIXME: Need circularity check. Later. + +(define (-class-check-init! class) + ; 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)) + + (begin + + ; First pass ensures all parents are initialized. + (for-each -class-check-init! + (-class-parent-classes class)) + + ; Next pass initializes the initial value list. + (letrec ((get-inits + (lambda (class) + (let ((parents (-class-parent-classes class))) + (append (apply append (map get-inits parents)) + (-class-my-initial-values class)))))) + + (let* ((parents (-class-parent-classes class)) + (inits (append (apply append (map get-inits parents)) + (-class-my-initial-values class)))) + (-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. + (-class-set-class-desc! class + (-class-compute-class-desc class 2 #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. +; 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) + (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". + (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)) + elm-list-tmp) + (+ index 1) + (cdr elms)) + (loop (acons (car elms) + (cons -object-unbound (cons #f index)) + elm-list-tmp) + (+ index 1) + (cdr elms))))) + + (let ((result (-class-make! name parents elm-list methods))) + + ; 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. + (method-make! result 'make! + (lambda args + (let ((self (car args))) + ; Ensure exactly all of the elements are provided. + (if (not (= (length args) + (- (vector-length (-object-elements self)) 1))) + (-object-error "make!" "" "wrong number of arguments to method `make!'")) + (-object-make-with-values! (-object-top-class self) + (-object-class-desc self) + (cdr args))))) + + result)) +) + +; Create an object of a class CLASS. + +(define (new class) + (-class-check class "new") + + (if -object-verbose? + (display (string-append "Instantiating class " (-class-name class) ".\n") + (current-error-port))) + + (-object-make! class) +) + +; Make a copy of OBJ. +; WARNING: A shallow copy is done on the elements! + +(define (object-copy obj) + (-object-check obj "object-copy") + (-object-copy obj #f) +) + +; 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! + +(define (object-copy-top obj) + (-object-check obj "object-copy-top") + (-object-copy obj #t) +) + +; Utility to define a standard `make!' method. +; A standard make! method is one in which all it does is initialize +; fields from args. + +(define (method-make-make! class args) + (let ((lambda-expr + (append (list 'lambda (cons 'self args)) + (map (lambda (elm) (list 'elm-set! 'self + (list 'quote elm) elm)) + args) + '(self)))) + (method-make! class 'make! (eval lambda-expr)) + ) +) + +; The "standard" way to invoke `make!' is (send (new class) 'make! ...). +; This puts all that in a cover function. + +(define (make class . operands) + (apply send (append (cons (new class) ()) '(make!) operands)) +) + +; Return #t if class X is a subclass of BASE-NAME. + +(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)))))) +) + +; 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. + +(define (class-instance? class object) + (-class-check class "class-instance?") + (if (object? object) + (-class-subclass? (-class-name class) (-object-class object)) + #f) +) + +; 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. + +(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))) + (if (null? parents) + #f + (let ((elm (-class-lookup-element (car parents) elm-name))) + (if elm + elm + (loop (cdr parents))))) + )) + ) +) + +; 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 is bound in OBJ. + +(define (elm-bound? obj elm) + (-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))) +) + +; Subroutine of elm-get. + +(define (-elm-make-method-getter self name) + (-object-check self "elm-get") + (let ((index (-class-lookup-element (-object-class-desc self) 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))) +) + +; 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. + +(defmacro elm-get (self name) + (if (eq? self 'self) + `(((-elm-make-method-getter ,self ,name)) ,self) + `(elm-xget ,self ,name)) +) + +; Subroutine of elm-set!. + +(define (-elm-make-method-setter self name) + (-object-check self "elm-set!") + (let ((index (-class-lookup-element (-object-class-desc self) 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))) +) + +; 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) + (if (eq? self 'self) + `(((-elm-make-method-setter ,self ,name)) ,self ,new-val) + `(elm-xset! ,self ,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) + (-object-check obj "elm-xget") + (let ((index (-class-lookup-element (-object-class-desc obj) name))) + ; FIXME: check private? + (if index + (-object-elm-get obj (car index) (-elm-delta index)) + (-object-error "elm-xget" obj "element not present: " 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) + (-object-check obj "elm-xset!") + (let ((index (-class-lookup-element (-object-class-desc obj) name))) + ; FIXME: check private? + (if index + (-object-elm-set! obj (car index) (-elm-delta index) new-val) + (-object-error "elm-xset!" obj "element not present: " name))) +) + +; Return a boolean indicating if object OBJ has element NAME. + +(define (elm-present? obj name) + (-object-check obj "elm-present?") + (->bool (-class-lookup-element (-object-class-desc obj) name)) +) + +; Return lambda to get element NAME in CLASS. +; FIXME: validate name. + +(define (elm-make-getter class 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)))) + (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))))) +) + +; Return lambda to set element NAME in CLASS. +; FIXME: validate name. + +(define (elm-make-setter class 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)))) + (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))) +) + +; 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. + +(define (-method-lookup-next class-desc method-name) + (let loop ((parents (-class-desc-parents class-desc))) + (if (null? parents) + #f + (let ((meth (-method-lookup (car parents) method-name #f))) + (if meth + meth + (loop (cdr parents)))))) +) + +; 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. + +(define (-method-lookup class-desc method-name virtual?) + (if -object-verbose? + (display (string-append "Looking up method " method-name " in " + (-class-name (-class-desc-class class-desc)) ".\n") + (current-error-port))) + + (let ((meth (assq method-name (-class-methods (-class-desc-class class-desc))))) + (if meth + (if (and virtual? (cadr meth)) ; virtual? + ; Traverse back up the inheritance chain looking for overriding + ; methods. The closest one to the top is the one to use. + (let loop ((child (-class-desc-child class-desc)) + (goal-class-desc class-desc) + (goal-meth meth)) + (if child + (begin + (if -object-verbose? + (display (string-append "Looking up virtual method " + method-name " in " + (-class-name (-class-desc-class child)) + ".\n") + (current-error-port))) + (let ((meth (assq method-name (-class-methods (-class-desc-class child))))) + (if meth + ; Method found, update goal object and method. + (loop (-class-desc-child child) child meth) + ; Method not found at this level. + (loop (-class-desc-child child) goal-class-desc goal-meth)))) + ; Went all the way up to the top. + (cons goal-class-desc (cddr goal-meth)))) + ; Non-virtual, done. + (cons class-desc (cddr meth))) + ; Method not found, search parents. + (-method-lookup-next class-desc method-name))) +) + +; Return a boolean indicating if object OBJ has method NAME. + +(define (method-present? obj name) + (-object-check obj "method-present?") + (->bool (-method-lookup (-object-class-desc obj) name #f)) +) + +; Return method NAME of CLASS or #f if not present. +; ??? Assumes CLASS has been initialized. + +(define (method-proc class name) + (-class-check class "method-proc") + (let ((meth (-method-lookup (-class-class-desc class) name #t))) + (if meth + (cdr meth) + #f)) +) + +; 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!") + (if (not (procedure? method)) + (-object-error "method-make!" method "method must be a procedure")) + (-class-set-methods! class (acons method-name + (cons #f method) + (-class-methods class))) + -object-unspecified +) + +; Add a virtual method to a class. +; FIXME: ensure method-name is a symbol + +(define (method-make-virtual! class method-name method) + (-class-check class "method-make-virtual!") + (if (not (procedure? method)) + (-object-error "method-make-virtual!" method "method must be a procedure")) + (-class-set-methods! class (acons method-name + (cons #t method) + (-class-methods class))) + -object-unspecified +) + +; 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 + +(define (method-make-forward! class elm-name methods) + (for-each (lambda (method-name) + (method-make! + class method-name + (eval `(lambda args + (apply send + (cons (elm-get (car args) + (quote ,elm-name)) + (cons (quote ,method-name) + (cdr args)))))))) + methods) + -object-unspecified +) + +; Same as method-make-forward! but creates virtual methods. +; FIXME: ensure elm-name is a symbol + +(define (method-make-virtual-forward! class elm-name methods) + (for-each (lambda (method-name) + (method-make-virtual! + class method-name + (eval `(lambda args + (apply send + (cons (elm-get (car args) + (quote ,elm-name)) + (cons (quote ,method-name) + (cdr args)))))))) + methods) + -object-unspecified +) + +; Utility of send, send-next. + +(define (-object-method-notify obj method-name maybe-next) + (set! -object-verbose? #f) + (display (string-append "Sending " maybe-next method-name " to" + (if (method-present? obj 'get-name) + (let ((name (send obj 'get-name))) + (if (or (symbol? name) (string? name)) + (string-append " object " name) + "")) + "") + " class " (object-class-name obj) ".\n") + (current-error-port)) + (set! -object-verbose? #t) +) + +; 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. + +(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 #t))) + (if class-desc.meth + (apply (cdr class-desc.meth) + (cons (-object-specialize obj (car class-desc.meth)) + 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. +; 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? + +(define (send-next obj 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))) + (if class-desc.meth + (apply (cdr class-desc.meth) + (cons (-object-specialize obj (car class-desc.meth)) + args)) + (-object-error "send-next" obj "method not supported: " method-name))) +) + +; 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 +) + +; Miscellaneous publically accessible utilities. + +; Reset the object system (delete all classes). + +(define (object-reset!) + (set! -class-list ()) + -object-unspecified +) + +; 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. + +(define (object-init!) + (for-each (lambda (class) + (-class-set-all-initial-values! class #f) + (-class-set-all-methods! class #f) + (-class-set-class-desc! class #f)) + (class-list)) + (for-each (lambda (class) + (-class-check-init! class)) + (class-list)) + -object-unspecified +) + +; Return list of all classes. + +(define (class-list) (map cdr -class-list)) + +; Utility to map over a class and all its parent classes, recursively. + +(define (class-map-over-class proc class) + (cons (proc class) + (map (lambda (class) (class-map-over-class proc class)) + (-class-parent-classes class))) +) + +; Return class tree of a class or object. + +(define (class-tree class-or-object) + (cond ((class? class-or-object) + (class-map-over-class class-name class-or-object)) + ((object? class-or-object) + (class-map-over-class class-name (-object-class class-or-object))) + (else (-object-error "class-tree" class-or-object + "not a class or object"))) +) + +; Return names of each alist. + +(define (-class-alist-names class) + (list (-class-name class) + (map car (-class-elements class)) + (map car (-class-methods class))) +) + +; Return complete layout of class-or-object. + +(define (class-layout class-or-object) + (cond ((class? class-or-object) + (class-map-over-class -class-alist-names class-or-object)) + ((object? class-or-object) + (class-map-over-class -class-alist-names (-object-class class-or-object))) + (else (-object-error "class-layout" class-or-object + "not a class or object"))) +) + +; Like assq but based on the `name' element. +; WARNING: Slow. + +(define (object-assq name obj-list) + (find-first (lambda (o) (eq? (elm-xget o 'name) name)) + obj-list) +) + +; Like memq but based on the `name' element. +; WARNING: Slow. + +(define (object-memq name obj-list) + (let loop ((r obj-list)) + (cond ((null? r) #f) + ((eq? name (elm-xget (car r) 'name)) r) + (else (loop (cdr r))))) +) + +; 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. + +(if (defined? 'vector-copy) + (define -object-vector-copy vector-copy) + (define (-object-vector-copy v) (list->vector (vector->list v))) +) + +; Profiling support + +(if (and #f (defined? 'proc-profile)) + (begin + (proc-profile elm-get) + (proc-profile elm-set!) + (proc-profile elm-present?) + (proc-profile -method-lookup) + (proc-profile send) + (proc-profile new) + (proc-profile make) + )) |