1 ;; Cgen's Object System.
2 ;; Copyright (C) 2000, 2009, 2010 Red Hat, Inc.
3 ;; This file is part of CGEN.
4 ;; See file COPYING.CGEN for details.
6 ;; Scheme implementations don't agree on a lot of things beyond the basics.
7 ;; This is a simple object system for cgen's needs.
8 ;; I thought at the start that when Guile had an official object system
9 ;; we'd switch over, but the higher order bit now is to be usable on
10 ;; multiple Scheme implementations: Guile isn't fast enough.
12 ;; NOTE: The original COS supported multiple inheritance. This does not.
18 ;; class-uid ;; unique id of class, index into /class-table
20 ;; elm-alist ;; not including parent classes
21 ;; method-alist ;; not including parent classes
22 ;; full-elm-initial-list ;; including parent classes
23 ;; method-cache ;; ??? not currently used
26 ;; PARENT-NAME is the name of the parent class, if any.
27 ;; If a subclasses b which subclasses c, then parent-name for a is b,
28 ;; the parent-name for b is c, and the parent-name for c is #f.
30 ;; ELM-ALIST is an alist of (symbol vector-offset-with-class . initial-value)
31 ;; for this class only.
32 ;; Values can be looked up by name, via elm-make-[gs]etter routines, or
33 ;; methods can use elm-get/set! for speed.
34 ;; Various Lisp (or Lisp-like) OOP systems (e.g. CLOS, Dylan) call these
35 ;; "slots". Maybe for consistency "slot" would be a better name. Some might
36 ;; confuse that with intentions at directions.
38 ;; METHOD-ALIST is an alist of (symbol . procedure) for this class only.
40 ;; FULL-ELM-INITIAL-LIST is the elements of the flattened inheritance tree.
41 ;; Initially it is #f meaning it hasn't been computed yet.
42 ;; It is computed when the class is first instantiated. During development,
43 ;; it can be reset to #f after some module has been reloaded (as long as no
44 ;; elements have been deleted/added/moved/etc., existing objects are ok).
46 ;; METHOD-CACHE is an alist of the methods of the flattened inheritance
47 ;; tree. Each element is (symbol . (parent-list-entry . method)).
48 ;; Initially it is #f meaning it hasn't been computed yet.
49 ;; It is computed when the class is first instantiated. During development,
50 ;; it can be reset to #f after some module has been reloaded (requires all
51 ;; object instantiation to happen later of course).
52 ;; FIXME: We don't yet implement the method cache.
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 offset child-backpointer [parent-descriptor]).
57 ;; offset is the offset in the element vector of the class's elements.
58 ;; child-backpointer is #f in the top level object.
59 ;; ??? child->subclass, parent->superclass?
60 ;; Initially the class-descriptor is #f meaning it hasn't been computed yet.
61 ;; It is computed when the class is first instantiated. During development,
62 ;; it can be reset to #f after some module has been reloaded (requires all
63 ;; object instantiation to happen later of course).
65 ;; An object is a vector: #(object-tag class-name class-uid elm1 elm2 ...)
66 ;; Vectors are nice in that they're self-evaluating.
67 ;; Both class name and uid are stored here for a better developer experience.
68 ;; It might be better to store the class-descriptor instead, but it's big and
69 ;; vastly reduces the S/N ratio when displaying objects.
71 ;; -----------------------------------------------------------------------------
73 ;; User visible procs:
75 ;; (class-make name parents elements methods) -> class
77 ;; Create a class. The result is then passed back by procedures requiring
78 ;; a class argument. Note however that PARENTS is a list of class names,
79 ;; not the class data type. This allows reloading the definition of a
80 ;; parent class without having to reload any subclasses. To implement this
81 ;; classes are recorded internally, and `object-init!' must be called if any
82 ;; class has been redefined.
84 ;; (class-list) -> list of all defined classes
86 ;; (class-name class) -> name of CLASS
88 ;; (class-lookup class-name) -> class
90 ;; (class-instance? class object) -> #t if OBJECT is an instance of CLASS
92 ;; (object-class object) -> class of OBJECT
94 ;; (object-class-name object) -> class name of OBJECT
96 ;; (send object method-name . args) -> result of invoking METHOD-NAME
98 ;; (send-next object class-name method-name . args) -> result of invoking next METHOD-NAME
100 ;; (new class) -> instantiate CLASS
102 ;; The object is initialized with values specified when CLASS
103 ;; (and its parent classes) was defined.
105 ;; (vmake class . args) -> instantiate class and initialize it with 'vmake!
107 ;; This is shorthand for (send (new class) 'vmake! args).
108 ;; ARGS is a list of option names and arguments (a la CLOS).
109 ;; ??? Not implemented yet.
111 ;; (method-vmake! object . args) -> modify OBJECT from ARGS
113 ;; This is the standard 'vmake! method, available for use by user-written
115 ;; ??? Not implemented yet.
117 ;; (make class . args) -> instantiate CLASS and initialize it with 'make!
119 ;; This is shorthand for (send (new class) 'make! arg1 ...).
120 ;; This is a positional form of `new'.
122 ;; (method-make-make! class elm1-name elm2-name ...) -> unspecified
124 ;; Create a 'make! method that sets the specified elements.
126 ;; (object-copy object) -> copy of OBJ
128 ;; ??? Whether to discard the parent or keep it and retain specialization
131 ;; (object-copy-top object) -> copy of OBJECT with spec'n discarded
133 ;; (class? foo) -> return #t if FOO is a class
135 ;; (object? foo) -> return #t if FOO is an object
137 ;; (method-make! class name lambda) -> unspecified
139 ;; Add method NAME to CLASS.
141 ;; (method-make-forward! class elm-name methods) -> unspecified
143 ;; Add METHODS to CLASS that pass the "message" onto the object in element
146 ;; (elm-get object elm-name) -> value of element ELM-NAME in OBJ
148 ;; Can only be used in methods.
150 ;; (elm-set! object elm-name new-value) -> unspecified
152 ;; Set element ELM-NAME in OBJECT to NEW-VALUE.
153 ;; Can only be used in methods.
155 ;; (elm-make-getter class elm-name) -> lambda
157 ;; Return lambda to get the value of ELM-NAME in CLASS.
159 ;; (elm-make-setter class elm-name) -> lambda
161 ;; Return lambda to set the value of ELM-NAME in CLASS.
163 ;; Conventions used in this file:
164 ;; - procs/vars internal to this file are prefixed with "-"
165 ;; [Of course this could all be put in a module; later if ever since
166 ;; once Guile has its own official object system we'll convert. Note that
167 ;; it currently does not.]
168 ;; - except for a few exceptions, public procs begin with one of
169 ;; class-, object-, elm-, method-.
170 ;; The exceptions are make, new, parent, send.
172 (define /class-tag "class")
173 (define /object-tag "object")
175 ;; Alist of all classes.
176 ;; Each element is (class-name class?-object).
177 ;; Note that classes are consed unto the front.
179 (define /class-list '())
181 ;; Table of all classes, indexed by class-uid.
182 ;; Note that classes are appended to the end.
184 (define /class-table '#())
186 ;; Internal variables to mark their respective properties.
187 (define /object-unspecified #:unspecified)
188 (define /object-unbound #:unbound)
190 ;; True if error messages are verbose and debugging messages are printed.
192 (define /object-verbose? #f)
194 ;; Cover fn to set verbosity.
196 (define (object-set-verbose! verbose?)
197 (set! /object-verbose? verbose?)
200 ;; Signal error if not class/object.
202 (define (/class-check maybe-class proc-name . extra-text)
203 (if (not (class? maybe-class))
205 (append! (list proc-name maybe-class "not a class")
210 (define (/object-check-name maybe-name proc-name . extra-text)
211 (if (not (symbol? maybe-name))
213 (append! (list proc-name maybe-name) extra-text)))
217 (define (/object-check maybe-object proc-name . extra-text)
218 (if (not (object? maybe-object))
220 (append! (list proc-name maybe-object "not an object")
225 ;; Main routine to flag a cos error.
226 ;; X is any arbitrary Scheme data.
228 (define (/object-error proc-name x . text)
229 (error (string-append proc-name ": "
230 (apply string-append (map ->string text))
233 " (class: " (->string (/object-class-name x))
234 (if (method-present? x 'get-name)
235 (string-append ", name: "
236 (->string (send x 'get-name)))
244 ;; Low level class operations.
246 ;; Return boolean indicating if X is a class.
248 (define (class? class)
249 (and (vector? class) (eq? /class-tag (vector-ref class 0)))
254 (define (/class-name class) (vector-ref class 1))
255 (define (/class-uid class) (vector-ref class 2))
256 (define (/class-parent-name class) (vector-ref class 3))
257 (define (/class-elements class) (vector-ref class 4))
258 (define (/class-methods class) (vector-ref class 5))
259 (define (/class-all-initial-values class) (vector-ref class 6))
260 (define (/class-method-cache class) (vector-ref class 7))
261 (define (/class-class-desc class) (vector-ref class 8))
263 (define (/class-set-uid! class uid)
264 (vector-set! class 2 uid)
267 (define (/class-set-methods! class method-alist)
268 (vector-set! class 5 method-alist)
271 (define (/class-set-all-initial-values! class init-list)
272 (vector-set! class 6 init-list)
275 (define (/class-set-method-cache! class all-meth-list)
276 (vector-set! class 7 all-meth-list)
279 (define (/class-set-class-desc! class parent-list)
280 (vector-set! class 8 parent-list)
284 ;; The new definition overrides any existing definition.
286 (define (/class-make! name parent-name elements)
287 (let ((class (vector /class-tag name
288 #f ;; uid filled in later
290 '() ;; methods, none yet
292 (list-entry (assq name /class-list)))
294 (let ((uid (/class-uid (cdr list-entry))))
295 (/class-set-uid! class uid)
296 (set-cdr! list-entry class))
297 (let ((uid (vector-length /class-table)))
298 (/class-set-uid! class uid)
299 (set! /class-table (list->vector
300 (append (vector->list /class-table)
302 (set! /class-list (acons name class /class-list))))
306 ;; Lookup a class given its name.
307 ;; The result is the class or #f if not found.
309 (define (class-lookup name) (assq-ref /class-list name))
311 ;; Lookup a class given its uid.
313 (define (/class-lookup-uid uid) (vector-ref /class-table uid))
315 ;; Return a list of all direct parent classes of CLASS.
316 ;; The list can have at most one element.
317 ;; this is for callers that prefer a list result.
319 (define (/class-parent-classes class)
320 (if (/class-parent-name class)
321 (let ((parent (class-lookup (/class-parent-name class))))
324 ;; The proc name we pass here is made up as we don't
325 ;; want it to be the name of an internal proc.
326 (/object-error "class" parent "not a class")))
330 ;; Cover proc of /class-name for the outside world to use.
331 ;; The result is the name of the class or #f if CLASS is not a class.
332 ;; We could issue an error here, but to be consistent with object-class-name
335 (define (class-name class)
341 ;; Class descriptor utilities.
342 ;; A class-descriptor is:
343 ;; (class offset child-backpointer [parent-descriptor])
345 (define (/class-desc? maybe-class-desc)
346 (and (pair? maybe-class-desc)
347 (class? (car maybe-class-desc)))
349 (define /class-desc-class car)
350 (define /class-desc-offset cadr)
351 (define /class-desc-child caddr)
352 (define /class-desc-parents cdddr) ;; nil or list of one element
354 ;; Compute the class descriptor of CLASS.
355 ;; OFFSET is the beginning offset in the element vector.
356 ;; We can assume the parents of CLASS have already been initialized.
358 ;; A class-descriptor is:
359 ;; (class offset child (parent-entry))
360 ;; CLASS is the class? data structure of the class.
361 ;; OFFSET is the offset into the object vector of the baseclass's elements.
362 ;; CHILD is the backlink to the direct child class or #f if no subclass.
363 ;; PARENT-ENTRY is the class descriptor of the parent class.
365 (define (/class-compute-class-desc class offset child)
367 ;; OFFSET must be global to the calculation because it is continually
368 ;; incremented as we recurse down through the hierarchy (actually, as we
369 ;; traverse back up). At any point in time it is the offset from the start
370 ;; of the element vector of the next class's elements.
371 ;; Object elements are laid out using a depth first traversal of the
374 (define (compute1 class child)
376 ;; Build the result first, then build our parents so that our parents have
377 ;; the right value for the CHILD-BACKPOINTER field.
378 ;; FIXME: Can't assume append! works that way.
379 ;; Use a bogus value for offset for the moment.
380 ;; The correct value is set later.
382 (let ((result (list class 999 child)))
384 ;; Recurse on the parent.
386 (if (/class-parent-name class)
387 (let ((parent (class-lookup (/class-parent-name class))))
389 ;; The proc name we pass here is made up as we don't
390 ;; want it to be the name of an internal proc.
391 (/object-error "class" (car parents) "not a class"))
393 (let ((parent-desc (compute1 parent result)))
395 ;; We use `append!' here as the location of `result' is now fixed
396 ;; so that our parent's child-backpointer remains stable.
397 (append! result (list parent-desc)))))
399 (list-set! result 1 offset)
400 (set! offset (+ offset (length (/class-elements class))))
403 (compute1 class child)
406 ;; Return the top level class-descriptor of CLASS-DESC.
408 (define (/class-desc-top class-desc)
409 (if (/class-desc-child class-desc)
410 (/class-desc-top (/class-desc-child class-desc))
414 ;; Pretty print a class descriptor.
416 (define (class-desc-dump class-desc)
417 (let* ((cep (current-error-port))
418 (top-desc (/class-desc-top class-desc))
419 (spaces (lambda (n port)
420 (display (make-string n #\space) port)))
421 (writeln (lambda (indent port . args)
423 (for-each (lambda (arg) (display arg port))
427 (letrec ((dump (lambda (cd indent)
428 (writeln indent cep "Class: "
429 (/class-name (/class-desc-class cd)))
430 (writeln indent cep " offset: "
431 (/class-desc-offset cd))
432 (writeln indent cep " child: "
433 (if (/class-desc-child cd)
434 (/class-name (/class-desc-class
435 (/class-desc-child cd)))
437 (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
438 (/class-desc-parents cd))
440 (display "Top level class: " cep)
441 (display (/class-name (/class-desc-class top-desc)) cep)
447 ;; Low level object utilities.
450 ;; All elements get initial (or unbound) values.
452 (define (/object-make! class)
453 (/class-check-init! class)
454 (apply vector (append! (list /object-tag
457 (/class-all-initial-values class)))
460 ;; Make an object using VALUES.
461 ;; VALUES must specify all elements in the class (and parent classes).
463 (define (/object-make-with-values! class values)
464 (/class-check-init! class)
465 (apply vector (append! (list /object-tag
472 ;; WARNING: A shallow copy is currently done on the elements!
474 (define (/object-copy obj)
475 (/object-vector-copy obj)
480 (define (/object-class-name obj) (vector-ref obj 1))
481 (define (/object-class-uid obj) (vector-ref obj 2))
483 (define (/object-class-desc obj)
484 (/class-class-desc (/object-class obj))
487 (define (/object-class obj)
488 (/class-lookup-uid (/object-class-uid obj))
491 (define (/object-elm-get obj elm-offset)
492 (vector-ref obj elm-offset)
495 (define (/object-elm-set! obj elm-offset new-val)
496 (vector-set! obj elm-offset new-val)
500 ;; Return boolean indicating if X is an object.
502 (define (object? obj)
504 (>= (vector-length obj) 3)
505 (eq? /object-tag (vector-ref obj 0)))
508 ;; Return the class of an object.
510 (define (object-class obj)
511 (/object-check obj "object-class")
515 ;; Cover proc of /object-class-name for the outside world to use.
516 ;; The result is the name of the class or #f if OBJ is not an object.
518 (define (object-class-name obj)
520 (/object-class-name obj)
526 ;; Return the list of initial values for CLASS.
527 ;; The result does not include parent classes.
529 (define (/class-my-initial-values class)
530 (map cadr (/class-elements class))
533 ;; Initialize class if not already done.
534 ;; FIXME: Need circularity check. Later.
536 (define (/class-check-init! class)
537 ;; This should be fast the second time through, so don't do any
538 ;; computation until we know it's necessary.
540 (if (/class-all-initial-values class)
546 ;; First pass ensures all parents are initialized.
547 (for-each /class-check-init!
548 (/class-parent-classes class))
550 ;; Next pass initializes the initial value list.
553 (let ((parents (/class-parent-classes class)))
554 (append (apply append (map get-inits parents))
555 (/class-my-initial-values class))))))
557 (let* ((parents (/class-parent-classes class))
558 (inits (append (apply append (map get-inits parents))
559 (/class-my-initial-values class))))
560 (/class-set-all-initial-values! class inits)))
562 ;; Next pass initializes the class's class-descriptor.
563 ;; Object elements begin at offset 3 in the element vector.
564 (/class-set-class-desc! class
565 (/class-compute-class-desc class 3 #f))
573 ;; PARENTS is the name of parent class as a list, i.e. () or (<parent>).
574 ;; It's a list just in case multiple-inheritance is added one day.
575 ;; The parent need not exist yet, though it must exist when the class
576 ;; is first instantiated.
577 ;; ELMS is a either a list of either element names or name/value pairs.
578 ;; Elements without initial values are marked as "unbound".
579 ;; METHODS is an initial alist of methods. More methods can be added with
582 (define (class-make name parents elms methods)
583 (if (> (length parents) 1)
584 (/object-error 'class-make parents "multiple-inheritance is not supported"))
585 (if (> (length methods) 0)
586 (/object-error 'class-make methods "methods specified with class"))
590 ;; Mark elements without initial values as unbound, and
591 ;; compute indices into the element vector (relative to the class's
593 ;; Elements are recorded as (symbol initial-value . vector-index)
594 (let loop ((elm-list-tmp '()) (index 0) (elms elms))
596 (set! elm-list (reverse! elm-list-tmp)) ;; done
597 (if (pair? (car elms))
598 (loop (acons (caar elms)
599 (cons (cdar elms) index)
603 (loop (acons (car elms)
604 (cons /object-unbound index)
609 (let ((result (/class-make! name
610 (if (null? parents) #f (car parents))
613 ;; Create the standard `make!' method.
614 ;; The caller can override afterwards if desired.
615 ;; Note that if there are any parent classes then we don't know the names
616 ;; of all of the elements yet, that is only known after the class has been
617 ;; initialized which only happens when the class is first instantiated.
618 ;; This method won't be called until that happens though so we're safe.
619 ;; This is written without knowledge of the names, it just initializes
621 (method-make! result 'make!
623 (let ((self (car args)))
624 ;; Ensure exactly all of the elements are provided.
625 (if (not (= (length args)
626 (- (vector-length self) 2)))
627 (/object-error "make!" "" "wrong number of arguments to method `make!'"))
628 (/object-make-with-values! (/object-class self)
634 ;; Create an object of a class CLASS.
637 (/class-check class "new")
640 (display (string-append "Instantiating class " (/class-name class) ".\n")
641 (current-error-port)))
643 (/object-make! class)
646 ;; Make a copy of OBJ.
647 ;; WARNING: A shallow copy is done on the elements!
649 (define (object-copy obj)
650 (/object-check obj "object-copy")
654 ;; Make a copy of OBJ.
655 ;; This makes a copy of top level object, with any specialization discarded.
656 ;; WARNING: A shallow copy is done on the elements!
657 ;; FIXME: Delete, specialization gone.
659 (define (object-copy-top obj)
660 (/object-check obj "object-copy-top")
664 ;; Assign object SRC to object DST.
665 ;; They must have the same class.
667 (define (object-assign! dst src)
668 (/object-check dst "object-assign!")
669 (/object-check src "object-assign!")
670 (if (not (eq? (/object-class-name dst) (/object-class-name src)))
671 (/object-error "object-assign" (list dst src) "not same class"))
673 (let ((n (vector-length dst)))
677 (vector-set! dst i (vector-ref src i))
682 ;; Utility to define a standard `make!' method.
683 ;; A standard make! method is one in which all it does is initialize
686 (define (method-make-make! class args)
688 (append (list 'lambda (cons 'self args))
689 (map (lambda (elm) (list 'elm-set! 'self
690 (list 'quote elm) elm))
693 (method-make! class 'make! (eval1 lambda-expr))
697 ;; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
698 ;; This puts all that in a cover function.
700 (define (make class . operands)
701 (apply send (append (cons (new class) '()) '(make!) operands))
704 ;; Return #t if class X is a subclass of BASE-NAME.
706 (define (/class-subclass? base-name x)
707 (if (eq? base-name (/class-name x))
709 (let ((parent-name (/class-parent-name x)))
711 (/class-subclass? base-name (class-lookup parent-name))
715 ;; Return #t if OBJECT is an instance of CLASS.
716 ;; This does not signal an error if OBJECT is not an object as this is
717 ;; intended to be used in class predicates.
719 (define (class-instance? class object)
720 (/class-check class "class-instance?")
722 (/class-subclass? (/class-name class) (/object-class object))
726 ;; Element operations.
728 ;; Lookup an element in a class-desc.
729 ;; The result is elm-index or #f if not found.
731 (define (/class-lookup-element class-desc elm-name)
732 (let* ((class (/class-desc-class class-desc))
733 (elm (assq elm-name (/class-elements class))))
735 (+ (cddr elm) ;; elm is (name init-value . index)
736 (/class-desc-offset class-desc))
737 (let ((parents (/class-desc-parents class-desc)))
740 (/class-lookup-element (car parents) elm-name)))))
743 ;; Return a boolean indicating if ELM-NAME is bound in OBJ.
745 (define (elm-bound? obj elm-name)
746 (/object-check obj "elm-bound?")
747 (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
749 (not (eq? (/object-elm-get obj index) /object-unbound))
750 (/object-error "elm-get" self "element not present: " elm-name)))
753 ;; Subroutine of elm-get.
755 (define (/elm-make-method-getter self elm-name)
756 (/object-check self "elm-get")
757 (let ((index (/class-lookup-element (/object-class-desc self) elm-name)))
759 (procedure->memoizing-macro
762 (/object-elm-get obj ,index))))
763 (/object-error "elm-get" self "element not present: " elm-name)))
766 ;; Get an element from an object.
767 ;; If OBJ is `self' then the caller is required to be a method and we emit
768 ;; memoized code. Otherwise we do things the slow way.
769 ;; ??? There must be a better way.
770 ;; What this does is turn
771 ;; (elm-get self 'foo)
773 ;; ((/elm-make-method-get self 'foo) self)
774 ;; Note the extra set of parens. /elm-make-method-get then does the lookup of
775 ;; foo and returns a memoizing macro that returns the code to perform the
776 ;; operation with O(1). Cute, but I'm hoping there's an easier/better way.
778 (defmacro elm-get (self elm-name)
780 `(((/elm-make-method-getter ,self ,elm-name)) ,self)
781 `(elm-xget ,self ,elm-name))
784 ;; Subroutine of elm-set!.
786 (define (/elm-make-method-setter self elm-name)
787 (/object-check self "elm-set!")
788 (let ((index (/class-lookup-element (/object-class-desc self) elm-name)))
790 (procedure->memoizing-macro
792 `(lambda (obj new-val)
793 (/object-elm-set! obj ,index new-val))))
794 (/object-error "elm-set!" self "element not present: " elm-name)))
797 ;; Set an element in an object.
798 ;; This can only be used by methods.
799 ;; See the comments for `elm-get'!
801 (defmacro elm-set! (self elm-name new-val)
803 `(((/elm-make-method-setter ,self ,elm-name)) ,self ,new-val)
804 `(elm-xset! ,self ,elm-name ,new-val))
807 ;; Get an element from an object.
808 ;; This is for invoking from outside a method, and without having to
809 ;; use elm-make-getter. It should be used sparingly.
811 (define (elm-xget obj elm-name)
812 (/object-check obj "elm-xget")
813 (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
815 (/object-elm-get obj index)
816 (/object-error "elm-xget" obj "element not present: " elm-name)))
819 ;; Set an element in an object.
820 ;; This is for invoking from outside a method, and without having to
821 ;; use elm-make-setter. It should be used sparingly.
823 (define (elm-xset! obj elm-name new-val)
824 (/object-check obj "elm-xset!")
825 (let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
827 (/object-elm-set! obj index new-val)
828 (/object-error "elm-xset!" obj "element not present: " elm-name)))
831 ;; Return a boolean indicating if object OBJ has element ELM-NAME.
833 (define (elm-present? obj elm-name)
834 (/object-check obj "elm-present?")
835 (->bool (/class-lookup-element (/object-class-desc obj) elm-name))
838 ;; Return lambda to get element ELM-NAME in CLASS.
839 ;; FIXME: validate elm-name.
841 (define (elm-make-getter class elm-name)
842 (/class-check class "elm-make-getter")
843 ;; We use delay here as we can't assume parent classes have been
845 (let ((fast-index (delay (/class-lookup-element
846 (/class-class-desc class) elm-name))))
848 (let ((index (force fast-index)))
849 (/object-elm-get obj index))))
852 ;; Return lambda to set element ELM-NAME in CLASS.
853 ;; FIXME: validate elm-name.
855 (define (elm-make-setter class elm-name)
856 (/class-check class "elm-make-setter")
857 ;; We use delay here as we can't assume parent classes have been
859 (let ((fast-index (delay (/class-lookup-element
860 (/class-class-desc class) elm-name))))
862 (let ((index (force fast-index)))
863 (/object-elm-set! obj index newval))))
866 ;; Method operations.
868 ;; Lookup the next method in a class.
869 ;; This means begin the search in the parent.
871 (define (/method-lookup-next class-desc method-name)
872 (let ((parent-descs (/class-desc-parents class-desc)))
873 (if (null? parent-descs)
875 (let ((parent-desc (car parent-descs)))
876 (/method-lookup parent-desc method-name))))
879 ;; Lookup a method in a class.
880 ;; The result is (class-desc . method). If the method is found in a parent
881 ;; class, the associated parent class descriptor is returned.
883 (define (/method-lookup class-desc method-name)
885 (display (string-append "Looking up method " method-name " in "
886 (/class-name (/class-desc-class class-desc)) ".\n")
887 (current-error-port)))
889 (let ((meth (assq method-name (/class-methods (/class-desc-class class-desc)))))
892 (cons class-desc (cdr meth))
893 ;; Method not found, search parents.
894 (/method-lookup-next class-desc method-name)))
897 ;; Return a boolean indicating if object OBJ has method NAME.
899 (define (method-present? obj name)
900 (/object-check obj "method-present?")
901 (->bool (/method-lookup (/object-class-desc obj) name))
904 ;; Add a method to a class.
906 (define (method-make! class method-name method)
907 (/class-check class "method-make!")
908 (/object-check-name method-name "method-make!" "method-name must be a symbol")
909 (if (not (procedure? method))
910 (/object-error "method-make!" method "method must be a procedure"))
911 (/class-set-methods! class (acons method-name method
912 (/class-methods class)))
916 ;; Utility to create "forwarding" methods.
917 ;; METHODS are forwarded to class member ELM-NAME, assumed to be an object.
918 ;; The created methods take a variable number of arguments.
919 ;; Argument length checking will be done by the receiving method.
920 ;; FIXME: ensure elm-name is a symbol
922 (define (method-make-forward! class elm-name methods)
923 (for-each (lambda (method-name)
928 (cons (elm-get (car args)
930 (cons (quote ,method-name)
936 ;; Utility of send, send-next.
938 (define (/object-method-notify obj method-name maybe-next)
939 (set! /object-verbose? #f)
940 (display (string-append "Sending " maybe-next method-name " to"
941 (if (method-present? obj 'get-name)
942 (let ((name (send obj 'get-name)))
943 (if (or (symbol? name) (string? name))
944 (string-append " object " name)
947 " class " (object-class-name obj) ".\n")
948 (current-error-port))
949 (set! /object-verbose? #t)
952 ;; Invoke a method in an object.
953 ;; When the method is invoked, the (possible parent class) object in which the
954 ;; method is found is passed to the method.
955 ;; ??? The word `send' comes from "sending messages". Perhaps should pick
956 ;; a better name for this operation.
958 (define (send obj method-name . args)
959 (/object-check obj "send")
960 (if /object-verbose? (/object-method-notify obj method-name ""))
962 (let ((class-desc.meth (/method-lookup (/object-class-desc obj)
965 (apply (cdr class-desc.meth)
967 (/object-error "send" obj "method not supported: " method-name)))
970 ;; Invoke the next method named METHOD-NAME in the heirarchy of OBJ.
971 ;; i.e. the method that would have been invoked if the calling method
973 ;; CLASS-NAME is the class of the invoking method.
974 ;; It is present to simplify things: otherwise we have to either include in
975 ;; objects the notion a current class or specialization, or include the class
976 ;; as an argument to methods.
977 ;; This may only be called by a method.
978 ;; ??? Ideally we shouldn't need either CLASS-NAME or METHOD-NAME arguments.
979 ;; They could be removed with a bit of effort, but is it worth it?
980 ;; One possibility is if method-make! was a macro, then maybe send-next could
981 ;; work with method-make! and get the values from it.
983 (define (send-next obj class-name method-name . args)
984 (/object-check obj "send-next")
985 (if /object-verbose? (/object-method-notify obj method-name "next "))
987 (let* ((class (class-lookup class-name)) ;; FIXME: slow
988 (class-desc.meth (/method-lookup-next (/class-class-desc class)
991 (apply (cdr class-desc.meth)
993 (/object-error "send-next" obj "method not supported: " method-name)))
996 ;; Miscellaneous publically accessible utilities.
998 ;; Reset the object system (delete all classes).
1000 (define (object-reset!)
1001 (set! /class-list (list))
1002 (set! /class-table (vector))
1006 ;; Call once to initialize the object system.
1007 ;; Only necessary if classes have been modified after objects have been
1008 ;; instantiated. This usually happens during development only.
1010 (define (object-init!)
1011 (for-each (lambda (class)
1012 (/class-set-all-initial-values! class #f)
1013 (/class-set-all-methods! class #f)
1014 (/class-set-class-desc! class #f))
1016 (for-each (lambda (class)
1017 (/class-check-init! class))
1022 ;; Return list of all classes.
1024 (define (class-list) (map cdr /class-list))
1026 ;; Utility to map over a class and all its parent classes, recursively.
1028 (define (class-map-over-class proc class)
1030 (map (lambda (class) (class-map-over-class proc class))
1031 (/class-parent-classes class)))
1034 ;; Return class tree of a class or object.
1036 (define (class-tree class-or-object)
1037 (cond ((class? class-or-object)
1038 (class-map-over-class class-name class-or-object))
1039 ((object? class-or-object)
1040 (class-map-over-class class-name (/object-class class-or-object)))
1041 (else (/object-error "class-tree" class-or-object
1042 "not a class or object")))
1045 ;; Return names of each alist.
1047 (define (/class-alist-names class)
1048 (list (/class-name class)
1049 (map car (/class-elements class))
1050 (map car (/class-methods class)))
1053 ;; Return complete layout of class-or-object.
1055 (define (class-layout class-or-object)
1056 (cond ((class? class-or-object)
1057 (class-map-over-class /class-alist-names class-or-object))
1058 ((object? class-or-object)
1059 (class-map-over-class /class-alist-names (/object-class class-or-object)))
1060 (else (/object-error "class-layout" class-or-object
1061 "not a class or object")))
1064 ;; Like assq but based on the `name' element.
1067 (define (object-assq name obj-list)
1068 (find-first (lambda (o) (eq? (elm-xget o 'name) name))
1072 ;; Like memq but based on the `name' element.
1075 (define (object-memq name obj-list)
1076 (let loop ((r obj-list))
1077 (cond ((null? r) #f)
1078 ((eq? name (elm-xget (car r) 'name)) r)
1079 (else (loop (cdr r)))))
1082 ;; Misc. internal utilities.
1084 ;; We need a fast vector copy operation.
1085 ;; If `vector-copy' doesn't exist (which is assumed to be the fast one),
1086 ;; provide a simple version.
1088 (if (defined? 'vector-copy)
1089 (define /object-vector-copy vector-copy)
1090 (define (/object-vector-copy v) (list->vector (vector->list v)))