1 ; Cgen's Object System.
2 ; Copyright (C) 2000, 2009 Red Hat, Inc.
3 ; This file is part of CGEN.
4 ; See file COPYING.CGEN for details.
6 ; When Guile has an official object implementation that is stable, things will
7 ; be switched over then. Until such time, there's no point in getting hyper
8 ; (although doing so is certainly fun, but only to a point).
9 ; If the Guile team decides there won't be any official object system
10 ; (which isn't unreasonable) then we'll pick the final object system then.
11 ; Until such time, there are better things to do than trying to build a
12 ; better object system. If this is important enough to you, help the Guile
13 ; team finish the module(/object?) system.
22 ; full-elm-initial-list
23 ; full-method-alist ; ??? not currently used
26 ; PARENT-NAME-LIST is a list of the names of parent classes (the inheritance
29 ; ELM-ALIST is an alist of (symbol private? vector-index . initial-value)
30 ; for this class only.
31 ; Values can be looked up by name, via elm-make-[gs]etter routines, or
32 ; methods can use elm-get/set! for speed.
33 ; Various Lisp (or Lisp-like) OOP systems (e.g. CLOS, Dylan) call these
34 ; "slots". Maybe for consistency "slot" would be a better name. Some might
35 ; confuse that with intentions at directions. Given that something better
36 ; will eventually happen, being deliberately different is useful.
38 ; METHOD-ALIST is an alist of (symbol . (virtual? . procedure)) for this
41 ; FULL-ELM-INITIAL-LIST is the elements of the flattened inheritance tree.
42 ; Initially it is #f meaning it hasn't been computed yet.
43 ; It is computed when the class is first instantiated. During development,
44 ; it can be reset to #f after some module has been reloaded (requires all
45 ; object instantiation happens later of course).
47 ; FULL-METHOD-ALIST is an alist of the methods of the flattened inheritance
48 ; tree. Each element is (symbol . (parent-list-entry . method)).
49 ; Initially it is #f meaning it hasn't been computed yet.
50 ; It is computed when the class is first instantiated. During development,
51 ; it can be reset to #f after some module has been reloaded (requires all
52 ; object instantiation happens later of course).
54 ; CLASS-DESCRIPTOR is the processed form of parent-name-list.
55 ; There is an entry for the class and one for each parent (recursively):
56 ; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...).
57 ; mi? is #t if the class or any parent class has multiple inheritance.
58 ; This is used by the element access routines.
59 ; base-offset is the offset in the element vector of the baseclass (or first
60 ; baseclass in the mi case).
61 ; delta is the offset from base-offset of the class's own elements
62 ; (as opposed to elements in any parent class).
63 ; child-backpointer is #f in the top level object.
64 ; ??? child->subclass, parent->superclass?
65 ; Initially the class-descriptor is #f meaning it hasn't been computed yet.
66 ; It is computed when the class is first instantiated. During development,
67 ; it can be reset to #f after some module has been reloaded (requires all
68 ; object instantiation to happen later of course).
70 ; An object is a vector of 2 elements: #(object-elements class-descriptor).
71 ; ??? Things would be simpler if objects were a pair but that makes eval'ing
72 ; them trickier. Vectors are nice in that they're self-evaluating, though
73 ; due to the self-referencing, which Guile 1.2 can't handle, apps have to
75 ; ??? We could use smobs/records/whatever but the difference isn't big enough
76 ; for me to care at this point in time.
78 ; `object-elements' looks like:
86 ; CLASS is the class the object is an instance of.
90 ; (class-make name parents elements methods) -> class
92 ; Create a class. The result is then passed back by procedures requiring
93 ; a class argument. Note however that PARENTS is a list of class names,
94 ; not the class data type. This allows reloading the definition of a
95 ; parent class without having to reload any subclasses. To implement this
96 ; classes are recorded internally, and `object-init!' must be called if any
97 ; class has been redefined.
99 ; (class-list) -> list of all defined classes
101 ; (class-name class) -> name of CLASS
103 ; (class-lookup class-name) -> class
105 ; (class-instance? class object) -> #t if OBJECT is an instance of CLASS
107 ; (object-class object) -> class of OBJECT
109 ; (object-class-name object) -> class name of OBJECT
111 ; (send object method-name . args) -> result of invoking METHOD-NAME
113 ; (send-next object method-name . args) -> result of invoking next METHOD-NAME
115 ; (new class) -> instantiate CLASS
117 ; The object is initialized with values specified when CLASS
118 ; (and its parent classes) was defined.
120 ; (vmake class . args) -> instantiate class and initialize it with 'vmake!
122 ; This is shorthand for (send (new class) 'vmake! args).
123 ; ARGS is a list of option names and arguments (a la CLOS).
124 ; ??? Not implemented yet.
126 ; (method-vmake! object . args) -> modify OBJECT from ARGS
128 ; This is the standard 'vmake! method, available for use by user-written
130 ; ??? Not implemented yet.
132 ; (make class . args) -> instantiate CLASS and initialize it with 'make!
134 ; This is shorthand for (send (new class) 'make! arg1 ...).
135 ; This is a positional form of `new'.
137 ; (method-make-make! class elm1-name elm2-name ...) -> unspecified
139 ; Create a 'make! method that sets the specified elements.
141 ; (object-copy object) -> copy of OBJ
143 ; ??? Whether to discard the parent or keep it and retain specialization
146 ; (object-copy-top object) -> copy of OBJECT with spec'n discarded
148 ; (object-parent object parent-path) -> parent object in OBJECT via PARENT-PATH
150 ; (class? foo) -> return #t if FOO is a class
152 ; (object? foo) -> return #t if FOO is an object
154 ; (method-make! class name lambda) -> unspecified
156 ; Add method NAME to CLASS.
158 ; (method-make-virtual! class name lambda) -> unspecified
160 ; Add virtual method NAME to CLASS.
162 ; (method-make-forward! class elm-name methods) -> unspecified
164 ; Add METHODS to CLASS that pass the "message" onto the object in element
167 ; (method-make-virtual-forward! class elm-name methods) -> unspecified
169 ; Add virtual METHODS to CLASS that pass the "message" onto the object in
172 ; (elm-get object elm-name) -> value of element ELM-NAME in OBJ
174 ; Can only be used in methods.
176 ; (elm-set! object elm-name new-value) -> unspecified
178 ; Set element ELM-NAME in OBJECT to NEW-VALUE.
179 ; Can only be used in methods.
181 ; (elm-make-getter class elm-name) -> lambda
183 ; Return lambda to get the value of ELM-NAME in CLASS.
185 ; (elm-make-setter class elm-name) -> lambda
187 ; Return lambda to set the value of ELM-NAME in CLASS.
189 ; Conventions used in this file:
190 ; - procs/vars internal to this file are prefixed with "-"
191 ; [Of course this could all be put in a module; later if ever since
192 ; once Guile has its own official object system we'll convert. Note that
193 ; it currently does not.]
194 ; - except for a few exceptions, public procs begin with one of
195 ; class-, object-, elm-, method-.
196 ; The exceptions are make, new, parent, send.
198 (define /class-tag "class")
199 (define /object-tag "object")
201 ; List of all classes.
203 (define /class-list '())
205 ; ??? Were written as a procedures for Hobbit's sake (I think).
206 (define /object-unspecified #:unspecified)
207 (define /object-unbound #:unbound)
209 ; Associative list of classes to be traced.
211 (define /object-debug-classes #f)
213 ; Associative list of elements to be traced.
215 (define /object-debug-elements #f)
217 ; Associative list of messages to be traced.
219 (define /object-debug-methods #f)
221 ; True if error messages are verbose and debugging messages are printed.
223 (define /object-verbose? #f)
225 ; Cover fn to set verbosity.
227 (define (object-set-verbose! verbose?)
228 (set! /object-verbose? verbose?)
231 ; Signal error if not class/object.
233 (define (/class-check maybe-class proc-name . extra-text)
234 (if (not (class? maybe-class))
236 (append! (list proc-name maybe-class "not a class")
240 (define (/object-check-name maybe-name proc-name . extra-text)
241 (if (not (symbol? maybe-name))
243 (append! (list proc-name maybe-name) extra-text)))
246 (define (/object-check maybe-object proc-name . extra-text)
247 (if (not (object? maybe-object))
249 (append! (list proc-name maybe-object "not an object")
254 ; X is any arbitrary Scheme data.
255 (define (/object-error proc-name x . text)
256 (error (string-append proc-name ": "
257 (apply string-append (map ->string text))
260 " (class: " (->string (/object-class-name x))
261 (if (method-present? x 'get-name)
262 (string-append ", name: "
263 (->string (send x 'get-name)))
271 ; Low level class operations.
273 ; Return boolean indicating if X is a class.
275 (define (class? class)
276 (and (vector? class) (eq? /class-tag (vector-ref class 0)))
281 (define (/class-name class) (vector-ref class 1))
282 (define (/class-parents class) (vector-ref class 2))
283 (define (/class-elements class) (vector-ref class 3))
284 (define (/class-methods class) (vector-ref class 4))
285 (define (/class-all-initial-values class) (vector-ref class 5))
286 (define (/class-all-methods class) (vector-ref class 6))
287 (define (/class-class-desc class) (vector-ref class 7))
289 (define (/class-set-parents! class parents)
290 (vector-set! class 2 parents)
293 (define (/class-set-elements! class elm-alist)
294 (vector-set! class 3 elm-alist)
297 (define (/class-set-methods! class method-alist)
298 (vector-set! class 4 method-alist)
301 (define (/class-set-all-initial-values! class init-list)
302 (vector-set! class 5 init-list)
305 (define (/class-set-all-methods! class all-meth-list)
306 (vector-set! class 6 all-meth-list)
309 (define (/class-set-class-desc! class parent-list)
310 (vector-set! class 7 parent-list)
314 ; The new definition overrides any existing definition.
316 (define (/class-make! name parents elements methods)
317 (let ((class (vector /class-tag name parents elements methods #f #f #f))
318 (list-entry (assq name /class-list)))
320 (set-cdr! list-entry class)
321 (set! /class-list (acons name class /class-list)))
325 ; Lookup a class given its name.
326 ; The result is the class or #f if not found.
328 (define (class-lookup name) (assq-ref /class-list name))
330 ; Return a list of all direct parent classes of CLASS.
332 (define (/class-parent-classes class)
333 ; /class-parents returns the names, we want the actual classes.
334 (let loop ((parents (/class-parents class))
338 (let ((parent (class-lookup (car parents))))
340 ; The proc name we pass here is made up as we don't
341 ; want it to be the name of an internal proc.
342 (/object-error "class" (car parents) "not a class"))
343 (loop (cdr parents) (cons parent result)))))
346 ; Cover proc of /class-name for the outside world to use.
347 ; The result is the name of the class or #f if CLASS is not a class.
348 ; We could issue an error here, but to be consistent with object-class-name
351 (define (class-name class)
357 ; Return a boolean indicating if CLASS or any parent class has
358 ; multiple inheritance.
360 (define (/class-mi? class)
361 (/class-desc-mi? (/class-class-desc class))
364 ; Class descriptor utilities.
365 ; A class-descriptor is:
366 ; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
368 ;(define (/class-desc-make class offset bkptr parents)
369 ; (append (list class offset bkptr) parents)
371 (define (/class-desc? maybe-class-desc)
372 (and (pair? maybe-class-desc)
373 (class? (car maybe-class-desc)))
375 (define /class-desc-class car)
376 (define /class-desc-mi? cadr)
377 (define /class-desc-offset caddr)
378 (define /class-desc-offset-base caaddr)
379 (define /class-desc-offset-delta cdaddr)
380 (define /class-desc-child cadddr)
381 (define /class-desc-parents cddddr)
382 ; Note that this is an assq on the classes themselves, not their names.
383 ; The result is the parent's class-descriptor.
384 (define /class-desc-lookup-parent assq)
386 ; Compute the class descriptor of CLASS.
387 ; OFFSET is the beginning offset in the element vector.
388 ; We can assume the parents of CLASS have already been initialized.
390 ; A class-descriptor is:
391 ; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
392 ; MI? is a boolean indicating if multiple inheritance is present.
393 ; BASE-OFFSET is the offset into the object vector of the baseclass's elements
394 ; (or first baseclass in the mi case).
395 ; DELTA is the offset from BASE-OFFSET of the class's own elements.
396 ; CHILD is the backlink to the direct child class or #f for the top class.
397 ; ??? Is the use of `top' backwards from traditional usage?
399 (define (/class-compute-class-desc class offset child)
401 ; OFFSET must be global to the calculation because it is continually
402 ; incremented as we recurse down through the hierarchy (actually, as we
403 ; traverse back up). At any point in time it is the offset from the start
404 ; of the element vector of the next class's elements.
405 ; Object elements are laid out using a depth first traversal of the
408 (define (compute1 class child base-offset)
410 ; Build the result first, then build our parents so that our parents have
411 ; the right value for the CHILD-BACKPOINTER field.
412 ; Use a bogus value for mi? and offset for the moment.
413 ; The correct values are set later.
415 (let ((result (list class #f (cons 999 999) child))
416 (mi? (> (length (/class-parents class)) 1)))
418 ; Recurse on the parents.
419 ; We use `append!' here as the location of `result' is now fixed so
420 ; that our parent's child-backpointer remains stable.
423 (let loop ((parents (/class-parents class))
425 (base-offset base-offset))
427 (reverse! parent-descs)
428 (let ((parent (class-lookup (car parents))))
430 ; The proc name we pass here is made up as we don't
431 ; want it to be the name of an internal proc.
432 (/object-error "class" (car parents) "not a class"))
436 (let ((parent-desc (compute1 parent result base-offset)))
438 (cons parent-desc parent-descs)
441 (list-set! result 1 mi?)
442 (list-set! result 2 (cons base-offset (- offset base-offset)))
443 (set! offset (+ offset (length (/class-elements class))))
446 (compute1 class child offset)
449 ; Return the top level class-descriptor of CLASS-DESC.
451 (define (/class-desc-top class-desc)
452 (if (/class-desc-child class-desc)
453 (/class-desc-top (/class-desc-child class-desc))
457 ; Pretty print a class descriptor.
459 (define (class-desc-dump class-desc)
460 (let* ((cep (current-error-port))
461 (top-desc (/class-desc-top class-desc))
462 (spaces (lambda (n port)
463 (display (make-string n #\space) port)))
464 (writeln (lambda (indent port . args)
466 (for-each (lambda (arg) (display arg port))
470 (letrec ((dump (lambda (cd indent)
471 (writeln indent cep "Class: "
472 (/class-name (/class-desc-class cd)))
473 (writeln indent cep " mi?: "
474 (/class-desc-mi? cd))
475 (writeln indent cep " base offset: "
476 (/class-desc-offset-base cd))
477 (writeln indent cep " delta: "
478 (/class-desc-offset-delta cd))
479 (writeln indent cep " child: "
480 (if (/class-desc-child cd)
481 (/class-name (/class-desc-class
482 (/class-desc-child cd)))
484 (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
485 (/class-desc-parents cd))
487 (display "Top level class: " cep)
488 (display (/class-name (/class-desc-class top-desc)) cep)
494 ; Low level object utilities.
497 ; All elements get initial (or unbound) values.
499 (define (/object-make! class)
500 (/class-check-init! class)
501 (vector (apply vector (append! (list /object-tag class)
502 (/class-all-initial-values class)))
503 (/class-class-desc class))
506 ; Make an object using VALUES.
507 ; VALUES must specify all elements in the class (and parent classes).
509 (define (/object-make-with-values! class class-desc values)
510 (/class-check-init! class)
511 (vector (apply vector (append! (list /object-tag class) values))
516 ; If TOP?, the copy is of the top level object with any specialization
518 ; WARNING: A shallow copy is currently done on the elements!
520 (define (/object-copy obj top?)
522 (vector (/object-vector-copy (/object-elements obj))
523 (/class-class-desc (/object-top-class obj)))
524 (vector (/object-vector-copy (/object-elements obj))
525 (/object-class-desc obj)))
528 ; Specialize an object to be one from a parent class.
529 ; The result is the same object, but with a different view (confined to
530 ; a particular parent class).
532 (define (/object-specialize obj class-desc)
533 (vector (/object-elements obj) class-desc)
538 (define (/object-elements obj) (vector-ref obj 0))
539 (define (/object-class-desc obj) (vector-ref obj 1))
540 (define (/object-class obj) (/class-desc-class (/object-class-desc obj)))
541 (define (/object-class-name obj) (/class-name (/object-class obj)))
542 (define (/object-top-class obj) (vector-ref (/object-elements obj) 1))
544 (define (/object-elm-get obj class-desc elm-base-offset)
545 (vector-ref (/object-elements obj)
546 (+ (/class-desc-offset-base class-desc) elm-base-offset))
549 (define (/object-elm-set! obj class-desc elm-base-offset new-val)
550 (vector-set! (/object-elements obj)
551 (+ (/class-desc-offset-base class-desc) elm-base-offset)
556 ; Return a boolean indicating of OBJ has multiple-inheritance.
558 (define (/object-mi? obj)
559 (/class-mi? (/object-top-class obj))
562 ; Return boolean indicating if X is an object.
564 (define (object? obj)
566 (= (vector-length obj) 2)
567 (vector? (vector-ref obj 0))
568 (eq? /object-tag (vector-ref (vector-ref obj 0) 0))
569 (/class-desc? (vector-ref obj 1)))
572 ; Return the class of an object.
574 (define (object-class obj)
575 (/object-check obj "object-class")
579 ; Cover proc of /object-class-name for the outside world to use.
580 ; The result is the name of the class or #f if OBJ is not an object.
582 (define (object-class-name obj)
584 (/object-class-name obj)
590 ; Return the list of initial values for CLASS.
591 ; The result does not include parent classes.
593 (define (/class-my-initial-values class)
594 (map cadr (/class-elements class))
597 ; Initialize class if not already done.
598 ; FIXME: Need circularity check. Later.
600 (define (/class-check-init! class)
601 ; This should be fast the second time through, so don't do any
602 ; computation until we know it's necessary.
604 (if (not (/class-all-initial-values class))
608 ; First pass ensures all parents are initialized.
609 (for-each /class-check-init!
610 (/class-parent-classes class))
612 ; Next pass initializes the initial value list.
615 (let ((parents (/class-parent-classes class)))
616 (append (apply append (map get-inits parents))
617 (/class-my-initial-values class))))))
619 (let* ((parents (/class-parent-classes class))
620 (inits (append (apply append (map get-inits parents))
621 (/class-my-initial-values class))))
622 (/class-set-all-initial-values! class inits)))
624 ; Next pass initializes the class's class-descriptor.
625 ; Object elements begin at offset 2 in the element vector.
626 (/class-set-class-desc! class
627 (/class-compute-class-desc class 2 #f))
635 ; PARENTS is a list of names of parent classes. The parents need not
636 ; exist yet, though they must exist when the class is first instantiated.
637 ; ELMS is a either a list of either element names or name/value pairs.
638 ; Elements without initial values are marked as "unbound".
639 ; METHODS is an initial alist of methods. More methods can be added with
642 (define (class-make name parents elms methods)
645 ; Mark elements without initial values as unbound, and
646 ; compute indices into the element vector (relative to the class's
648 ; Elements are recorded as (symbol initial-value private? . vector-index)
649 ; FIXME: For now all elements are marked as "public".
650 (let loop ((elm-list-tmp '()) (index 0) (elms elms))
652 (set! elm-list (reverse! elm-list-tmp)) ; done
653 (if (pair? (car elms))
654 (loop (acons (caar elms)
655 (cons (cdar elms) (cons #f index))
659 (loop (acons (car elms)
660 (cons /object-unbound (cons #f index))
665 (let ((result (/class-make! name parents elm-list methods)))
667 ; Create the standard `make!' method.
668 ; The caller can override afterwards if desired.
669 ; Note that if there are any parent classes then we don't know the names
670 ; of all of the elements yet, that is only known after the class has been
671 ; initialized which only happens when the class is first instantiated.
672 ; This method won't be called until that happens though so we're safe.
673 ; This is written without knowledge of the names, it just initializes
675 (method-make! result 'make!
677 (let ((self (car args)))
678 ; Ensure exactly all of the elements are provided.
679 (if (not (= (length args)
680 (- (vector-length (/object-elements self)) 1)))
681 (/object-error "make!" "" "wrong number of arguments to method `make!'"))
682 (/object-make-with-values! (/object-top-class self)
683 (/object-class-desc self)
689 ; Create an object of a class CLASS.
692 (/class-check class "new")
695 (display (string-append "Instantiating class " (/class-name class) ".\n")
696 (current-error-port)))
698 (/object-make! class)
701 ; Make a copy of OBJ.
702 ; WARNING: A shallow copy is done on the elements!
704 (define (object-copy obj)
705 (/object-check obj "object-copy")
706 (/object-copy obj #f)
709 ; Make a copy of OBJ.
710 ; This makes a copy of top level object, with any specialization discarded.
711 ; WARNING: A shallow copy is done on the elements!
713 (define (object-copy-top obj)
714 (/object-check obj "object-copy-top")
715 (/object-copy obj #t)
718 ; Utility to define a standard `make!' method.
719 ; A standard make! method is one in which all it does is initialize
722 (define (method-make-make! class args)
724 (append (list 'lambda (cons 'self args))
725 (map (lambda (elm) (list 'elm-set! 'self
726 (list 'quote elm) elm))
729 (method-make! class 'make! (eval1 lambda-expr))
733 ; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
734 ; This puts all that in a cover function.
736 (define (make class . operands)
737 (apply send (append (cons (new class) '()) '(make!) operands))
740 ; Return #t if class X is a subclass of BASE-NAME.
742 (define (/class-subclass? base-name x)
743 (if (eq? base-name (/class-name x))
745 (let loop ((parents (/class-parents x)))
748 (if (/class-subclass? base-name (class-lookup (car parents)))
750 (loop (cdr parents))))))
753 ; Return #t if OBJECT is an instance of CLASS.
754 ; This does not signal an error if OBJECT is not an object as this is
755 ; intended to be used in class predicates.
757 (define (class-instance? class object)
758 (/class-check class "class-instance?")
760 (/class-subclass? (/class-name class) (/object-class object))
764 ; Element operations.
766 ; Lookup an element in a class-desc.
767 ; The result is (class-desc . (private? . elm-offset)) or #f if not found.
768 ; ??? We could define accessors of the result but knowledge of its format
769 ; is restricted to this section of the source.
771 (define (/class-lookup-element class-desc elm-name)
772 (let* ((class (/class-desc-class class-desc))
773 (elm (assq elm-name (/class-elements class))))
775 (cons class-desc (cddr elm))
776 (let loop ((parents (/class-desc-parents class-desc)))
779 (let ((elm (/class-lookup-element (car parents) elm-name)))
782 (loop (cdr parents)))))
787 ; Given the result of /class-lookup-element, return the element's delta
790 (define (/elm-delta index)
791 (+ (/class-desc-offset-delta (car index))
795 ; Return a boolean indicating if ELM is bound in OBJ.
797 (define (elm-bound? obj elm)
798 (/object-check obj "elm-bound?")
799 (let* ((index (/class-lookup-element (/object-class-desc obj) elm))
800 (val (/object-elm-get obj (car index) (/elm-delta index))))
801 (not (eq? val /object-unbound)))
804 ; Subroutine of elm-get.
806 (define (/elm-make-method-getter self name)
807 (/object-check self "elm-get")
808 (let ((index (/class-lookup-element (/object-class-desc self) name)))
810 (procedure->memoizing-macro
813 (/object-elm-get obj (/object-class-desc obj)
814 ,(/elm-delta index)))))
815 (/object-error "elm-get" self "element not present: " name)))
818 ; Get an element from an object.
819 ; If OBJ is `self' then the caller is required to be a method and we emit
820 ; memoized code. Otherwise we do things the slow way.
821 ; ??? There must be a better way.
822 ; What this does is turn
823 ; (elm-get self 'foo)
825 ; ((-elm-make-method-get self 'foo) self)
826 ; Note the extra set of parens. -elm-make-method-get then does the lookup of
827 ; foo and returns a memoizing macro that returns the code to perform the
828 ; operation with O(1). Cute, but I'm hoping there's an easier/better way.
830 (defmacro elm-get (self name)
832 `(((/elm-make-method-getter ,self ,name)) ,self)
833 `(elm-xget ,self ,name))
836 ; Subroutine of elm-set!.
838 (define (/elm-make-method-setter self name)
839 (/object-check self "elm-set!")
840 (let ((index (/class-lookup-element (/object-class-desc self) name)))
842 (procedure->memoizing-macro
844 `(lambda (obj new-val)
845 (/object-elm-set! obj (/object-class-desc obj)
846 ,(/elm-delta index) new-val))))
847 (/object-error "elm-set!" self "element not present: " name)))
850 ; Set an element in an object.
851 ; This can only be used by methods.
852 ; See the comments for `elm-get'!
854 (defmacro elm-set! (self name new-val)
856 `(((/elm-make-method-setter ,self ,name)) ,self ,new-val)
857 `(elm-xset! ,self ,name ,new-val))
860 ; Get an element from an object.
861 ; This is for invoking from outside a method, and without having to
862 ; use elm-make-getter. It should be used sparingly.
864 (define (elm-xget obj name)
865 (/object-check obj "elm-xget")
866 (let ((index (/class-lookup-element (/object-class-desc obj) name)))
867 ; FIXME: check private?
869 (/object-elm-get obj (car index) (/elm-delta index))
870 (/object-error "elm-xget" obj "element not present: " name)))
873 ; Set an element in an object.
874 ; This is for invoking from outside a method, and without having to
875 ; use elm-make-setter. It should be used sparingly.
877 (define (elm-xset! obj name new-val)
878 (/object-check obj "elm-xset!")
879 (let ((index (/class-lookup-element (/object-class-desc obj) name)))
880 ; FIXME: check private?
882 (/object-elm-set! obj (car index) (/elm-delta index) new-val)
883 (/object-error "elm-xset!" obj "element not present: " name)))
886 ; Return a boolean indicating if object OBJ has element NAME.
888 (define (elm-present? obj name)
889 (/object-check obj "elm-present?")
890 (->bool (/class-lookup-element (/object-class-desc obj) name))
893 ; Return lambda to get element NAME in CLASS.
894 ; FIXME: validate name.
896 (define (elm-make-getter class name)
897 (/class-check class "elm-make-getter")
898 ; We use delay here as we can't assume parent classes have been
900 (let ((fast-index (delay (/class-lookup-element
901 (/class-class-desc class) name))))
903 ; ??? Should be able to use fast-index in mi case.
904 ; ??? Need to involve CLASS in lookup.
905 (let ((index (if (/object-mi? obj)
906 (/class-lookup-element (/object-class-desc obj) name)
907 (force fast-index))))
908 (/object-elm-get obj (car index) (/elm-delta index)))))
911 ; Return lambda to set element NAME in CLASS.
912 ; FIXME: validate name.
914 (define (elm-make-setter class name)
915 (/class-check class "elm-make-setter")
916 ; We use delay here as we can't assume parent classes have been
918 (let ((fast-index (delay (/class-lookup-element
919 (/class-class-desc class) name))))
921 ; ??? Should be able to use fast-index in mi case.
922 ; ??? Need to involve CLASS in lookup.
923 (let ((index (if (/object-mi? obj)
924 (/class-lookup-element (/object-class-desc obj) name)
925 (force fast-index))))
926 (/object-elm-set! obj (car index) (/elm-delta index) newval))))
929 ; Return a list of all elements in OBJ.
931 (define (elm-list obj)
932 (cddr (vector->list (/object-elements obj)))
937 ; Lookup the next method in a class.
938 ; This means begin the search in the parents.
939 ; ??? What should this do for virtual methods. At present we treat them as
942 (define (/method-lookup-next class-desc method-name)
943 (let loop ((parents (/class-desc-parents class-desc)))
946 (let ((meth (/method-lookup (car parents) method-name #f)))
949 (loop (cdr parents))))))
952 ; Lookup a method in a class.
953 ; The result is (class-desc . method). If the method is found in a parent
954 ; class, the associated parent class descriptor is returned. If the method is
955 ; a virtual method, the appropriate subclass's class descriptor is returned.
956 ; VIRTUAL? is #t if virtual methods are to be treated as such.
957 ; Otherwise they're treated as normal methods.
959 ; FIXME: We don't yet implement the method cache.
961 (define (/method-lookup class-desc method-name virtual?)
963 (display (string-append "Looking up method " method-name " in "
964 (/class-name (/class-desc-class class-desc)) ".\n")
965 (current-error-port)))
967 (let ((meth (assq method-name (/class-methods (/class-desc-class class-desc)))))
969 (if (and virtual? (cadr meth)) ; virtual?
970 ; Traverse back up the inheritance chain looking for overriding
971 ; methods. The closest one to the top is the one to use.
972 (let loop ((child (/class-desc-child class-desc))
973 (goal-class-desc class-desc)
978 (display (string-append "Looking up virtual method "
980 (/class-name (/class-desc-class child))
982 (current-error-port)))
983 (let ((meth (assq method-name (/class-methods (/class-desc-class child)))))
985 ; Method found, update goal object and method.
986 (loop (/class-desc-child child) child meth)
987 ; Method not found at this level.
988 (loop (/class-desc-child child) goal-class-desc goal-meth))))
989 ; Went all the way up to the top.
990 (cons goal-class-desc (cddr goal-meth))))
992 (cons class-desc (cddr meth)))
993 ; Method not found, search parents.
994 (/method-lookup-next class-desc method-name)))
997 ; Return a boolean indicating if object OBJ has method NAME.
999 (define (method-present? obj name)
1000 (/object-check obj "method-present?")
1001 (->bool (/method-lookup (/object-class-desc obj) name #f))
1004 ; Return method NAME of CLASS or #f if not present.
1005 ; ??? Assumes CLASS has been initialized.
1007 (define (method-proc class name)
1008 (/class-check class "method-proc")
1009 (let ((meth (/method-lookup (/class-class-desc class) name #t)))
1015 ; Add a method to a class.
1016 ; FIXME: ensure method-name is a symbol
1018 (define (method-make! class method-name method)
1019 (/class-check class "method-make!")
1020 (if (not (procedure? method))
1021 (/object-error "method-make!" method "method must be a procedure"))
1022 (/class-set-methods! class (acons method-name
1024 (/class-methods class)))
1028 ; Add a virtual method to a class.
1029 ; FIXME: ensure method-name is a symbol
1031 (define (method-make-virtual! class method-name method)
1032 (/class-check class "method-make-virtual!")
1033 (if (not (procedure? method))
1034 (/object-error "method-make-virtual!" method "method must be a procedure"))
1035 (/class-set-methods! class (acons method-name
1037 (/class-methods class)))
1041 ; Utility to create "forwarding" methods.
1042 ; METHODS are forwarded to class member ELM-NAME, assumed to be an object.
1043 ; The created methods take a variable number of arguments.
1044 ; Argument length checking will be done by the receiving method.
1045 ; FIXME: ensure elm-name is a symbol
1047 (define (method-make-forward! class elm-name methods)
1048 (for-each (lambda (method-name)
1051 (eval1 `(lambda args
1053 (cons (elm-get (car args)
1055 (cons (quote ,method-name)
1061 ; Same as method-make-forward! but creates virtual methods.
1062 ; FIXME: ensure elm-name is a symbol
1064 (define (method-make-virtual-forward! class elm-name methods)
1065 (for-each (lambda (method-name)
1066 (method-make-virtual!
1068 (eval1 `(lambda args
1070 (cons (elm-get (car args)
1072 (cons (quote ,method-name)
1078 ; Utility of send, send-next.
1080 (define (/object-method-notify obj method-name maybe-next)
1081 (set! /object-verbose? #f)
1082 (display (string-append "Sending " maybe-next method-name " to"
1083 (if (method-present? obj 'get-name)
1084 (let ((name (send obj 'get-name)))
1085 (if (or (symbol? name) (string? name))
1086 (string-append " object " name)
1089 " class " (object-class-name obj) ".\n")
1090 (current-error-port))
1091 (set! /object-verbose? #t)
1094 ; Invoke a method in an object.
1095 ; When the method is invoked, the (possible parent class) object in which the
1096 ; method is found is passed to the method.
1097 ; ??? The word `send' comes from "sending messages". Perhaps should pick
1098 ; a better name for this operation.
1100 (define (send obj method-name . args)
1101 (/object-check obj "send")
1102 (/object-check-name method-name "send" "not a method name")
1103 (if /object-verbose? (/object-method-notify obj method-name ""))
1105 (let ((class-desc.meth (/method-lookup (/object-class-desc obj)
1108 (apply (cdr class-desc.meth)
1109 (cons (/object-specialize obj (car class-desc.meth))
1111 (/object-error "send" obj "method not supported: " method-name)))
1114 ; Invoke the next method named METHOD-NAME in the heirarchy of OBJ.
1115 ; i.e. the method that would have been invoked if the calling method
1117 ; This may only be called by a method.
1118 ; ??? Ideally we shouldn't need the METHOD-NAME argument. It could be
1119 ; removed with a bit of effort, but is it worth it?
1121 (define (send-next obj method-name . args)
1122 (/object-check obj "send-next")
1123 (/object-check-name method-name "send-next" "not a method name")
1124 (if /object-verbose? (/object-method-notify obj method-name "next "))
1126 (let ((class-desc.meth (/method-lookup-next (/object-class-desc obj)
1129 (apply (cdr class-desc.meth)
1130 (cons (/object-specialize obj (car class-desc.meth))
1132 (/object-error "send-next" obj "method not supported: " method-name)))
1135 ; Parent operations.
1137 ; Subroutine of `parent' to lookup a (potentially nested) parent class.
1138 ; The result is the parent's class-descriptor or #f if not found.
1140 (define (/class-parent class-desc parent)
1141 (let* ((parent-descs (/class-desc-parents class-desc))
1142 (desc (/class-desc-lookup-parent parent parent-descs)))
1145 (let loop ((parents parent-descs))
1148 (let ((desc (/class-parent (car parents) parent)))
1151 (loop (cdr parents))))))))
1154 ; Subroutine of `parent' to lookup a parent via a path.
1155 ; PARENT-PATH, a list, is the exact path to the parent class.
1156 ; The result is the parent's class-descriptor or #f if not found.
1157 ; For completeness' sake, if PARENT-PATH is empty, CLASS-DESC is returned.
1159 (define (/class-parent-via-path class-desc parent-path)
1160 (if (null? parent-path)
1162 (let ((desc (/class-desc-lookup-parent (car parent-path)
1163 (/class-desc-parents class-desc))))
1165 (if (null? (cdr parent-path))
1167 (/class-parent-via-path (car desc) (cdr parent-path)))
1171 ; Lookup a parent class of object OBJ.
1172 ; CLASS is either a class or a list of classes.
1173 ; If CLASS is a list, it is a (possibly empty) "path" to the parent.
1174 ; Otherwise it is any parent and is searched for breadth-first.
1175 ; ??? Methinks this should be depth-first.
1176 ; The result is OBJ, specialized to the found parent.
1178 (define (object-parent obj class)
1179 (/object-check obj "object-parent")
1180 (cond ((class? class) #t)
1181 ((list? class) (for-each (lambda (class) (/class-check class
1184 (else (/object-error "object-parent" class "invalid parent path")))
1186 ; Hobbit generates C code that passes the function
1187 ; /class-parent-via-path or /class-parent, not the appropriate
1189 ; (let ((result ((if (or (null? class) (pair? class))
1190 ; /class-parent-via-path
1193 ; So it's rewritten like this.
1194 (let ((result (if (class? class)
1195 (/class-parent (/object-class-desc obj) class)
1196 (/class-parent-via-path (/object-class-desc obj) class))))
1198 (/object-specialize obj result)
1199 (/object-error "object-parent" obj "parent not present")))
1200 ; FIXME: should print path in error message.
1203 ; Make PARENT-NAME a parent of CLASS, cons'd unto the front of the search
1204 ; order. This is used to add a parent class to a class after it has already
1205 ; been created. Obviously this isn't something one does willy-nilly.
1206 ; The parent is added to the front of the current parent list (affects
1209 (define (class-cons-parent! class parent-name)
1210 (/class-check class "class-cons-parent!")
1211 (/object-check-name parent-name "class-cons-parent!" "not a class name")
1212 (/class-set-parents! class (cons parent-name (/class-parents class)))
1216 ; Make PARENT-NAME a parent of CLASS, cons'd unto the end of the search order.
1217 ; This is used to add a parent class to a class after it has already been
1218 ; created. Obviously this isn't something one does willy-nilly.
1219 ; The parent is added to the end of the current parent list (affects
1222 (define (class-append-parent! class parent-name)
1223 (/class-check class "class-append-parent!")
1224 (/object-check-name parent-name "class-append-parent!" "not a class name")
1225 (/class-set-parents! obj (append (/class-parents obj) (list parent-name)))
1229 ; Miscellaneous publically accessible utilities.
1231 ; Reset the object system (delete all classes).
1233 (define (object-reset!)
1234 (set! /class-list '())
1238 ; Call once to initialize the object system.
1239 ; Only necessary if classes have been modified after objects have been
1240 ; instantiated. This usually happens during development only.
1242 (define (object-init!)
1243 (for-each (lambda (class)
1244 (/class-set-all-initial-values! class #f)
1245 (/class-set-all-methods! class #f)
1246 (/class-set-class-desc! class #f))
1248 (for-each (lambda (class)
1249 (/class-check-init! class))
1254 ; Return list of all classes.
1256 (define (class-list) (map cdr /class-list))
1258 ; Utility to map over a class and all its parent classes, recursively.
1260 (define (class-map-over-class proc class)
1262 (map (lambda (class) (class-map-over-class proc class))
1263 (/class-parent-classes class)))
1266 ; Return class tree of a class or object.
1268 (define (class-tree class-or-object)
1269 (cond ((class? class-or-object)
1270 (class-map-over-class class-name class-or-object))
1271 ((object? class-or-object)
1272 (class-map-over-class class-name (/object-class class-or-object)))
1273 (else (/object-error "class-tree" class-or-object
1274 "not a class or object")))
1277 ; Return names of each alist.
1279 (define (/class-alist-names class)
1280 (list (/class-name class)
1281 (map car (/class-elements class))
1282 (map car (/class-methods class)))
1285 ; Return complete layout of class-or-object.
1287 (define (class-layout class-or-object)
1288 (cond ((class? class-or-object)
1289 (class-map-over-class /class-alist-names class-or-object))
1290 ((object? class-or-object)
1291 (class-map-over-class /class-alist-names (/object-class class-or-object)))
1292 (else (/object-error "class-layout" class-or-object
1293 "not a class or object")))
1296 ; Like assq but based on the `name' element.
1299 (define (object-assq name obj-list)
1300 (find-first (lambda (o) (eq? (elm-xget o 'name) name))
1304 ; Like memq but based on the `name' element.
1307 (define (object-memq name obj-list)
1308 (let loop ((r obj-list))
1309 (cond ((null? r) #f)
1310 ((eq? name (elm-xget (car r) 'name)) r)
1311 (else (loop (cdr r)))))
1314 ; Misc. internal utilities.
1316 ; We need a fast vector copy operation.
1317 ; If `vector-copy' doesn't exist (which is assumed to be the fast one),
1318 ; provide a simple version.
1319 ; FIXME: Need deep copier instead.
1321 (if (defined? 'vector-copy)
1322 (define /object-vector-copy vector-copy)
1323 (define (/object-vector-copy v) (list->vector (vector->list v)))
1328 (if (and #f (defined? 'proc-profile))
1330 (proc-profile elm-get)
1331 (proc-profile elm-xset!)
1332 (proc-profile elm-present?)
1333 (proc-profile /method-lookup)