cgen/cos.scm

   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.
   5 ;
   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.
  14 ;
  15 ; Classes look like:
  16 ;
  17 ; #(class-tag
  18 ;   class-name
  19 ;   parent-name-list
  20 ;   elm-alist
  21 ;   method-alist
  22 ;   full-elm-initial-list
  23 ;   full-method-alist ; ??? not currently used
  24 ;   class-descriptor)
  25 ;
  26 ; PARENT-NAME-LIST is a list of the names of parent classes (the inheritance
  27 ; tree).
  28 ;
  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.
  37 ;
  38 ; METHOD-ALIST is an alist of (symbol . (virtual? . procedure)) for this
  39 ; class only.
  40 ;
  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).
  46 ;
  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).
  53 ;
  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).
  69 ;
  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
  74 ; be careful.
  75 ; ??? We could use smobs/records/whatever but the difference isn't big enough
  76 ; for me to care at this point in time.
  77 ;
  78 ; `object-elements' looks like:
  79 ;
  80 ; #(object-tag
  81 ;   class
  82 ;   element1
  83 ;   element2
  84 ;   ...)
  85 ;
  86 ; CLASS is the class the object is an instance of.
  87 ;
  88 ; User visible procs:
  89 ;
  90 ; (class-make name parents elements methods) -> class
  91 ;
  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.
  98 ;
  99 ; (class-list) -> list of all defined classes
 100 ;
 101 ; (class-name class) -> name of CLASS
 102 ;
 103 ; (class-lookup class-name) -> class
 104 ;
 105 ; (class-instance? class object) -> #t if OBJECT is an instance of CLASS
 106 ;
 107 ; (object-class object) -> class of OBJECT
 108 ;
 109 ; (object-class-name object) -> class name of OBJECT
 110 ;
 111 ; (send object method-name . args) -> result of invoking METHOD-NAME
 112 ;
 113 ; (send-next object method-name . args) -> result of invoking next METHOD-NAME
 114 ;
 115 ; (new class) -> instantiate CLASS
 116 ;
 117 ; The object is initialized with values specified when CLASS
 118 ; (and its parent classes) was defined.
 119 ;
 120 ; (vmake class . args) -> instantiate class and initialize it with 'vmake!
 121 ;
 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.
 125 ;
 126 ; (method-vmake! object . args) -> modify OBJECT from ARGS
 127 ;
 128 ; This is the standard 'vmake! method, available for use by user-written
 129 ; 'vmake! methods.
 130 ; ??? Not implemented yet.
 131 ;
 132 ; (make class . args) -> instantiate CLASS and initialize it with 'make!
 133 ;
 134 ; This is shorthand for (send (new class) 'make! arg1 ...).
 135 ; This is a positional form of `new'.
 136 ;
 137 ; (method-make-make! class elm1-name elm2-name ...) -> unspecified
 138 ;
 139 ; Create a 'make! method that sets the specified elements.
 140 ;
 141 ; (object-copy object) -> copy of OBJ
 142 ;
 143 ; ??? Whether to discard the parent or keep it and retain specialization
 144 ; is undecided.
 145 ;
 146 ; (object-copy-top object) -> copy of OBJECT with spec'n discarded
 147 ;
 148 ; (object-parent object parent-path) -> parent object in OBJECT via PARENT-PATH
 149 ;
 150 ; (class? foo) -> return #t if FOO is a class
 151 ;
 152 ; (object? foo) -> return #t if FOO is an object
 153 ;
 154 ; (method-make! class name lambda) -> unspecified
 155 ;
 156 ; Add method NAME to CLASS.
 157 ;
 158 ; (method-make-virtual! class name lambda) -> unspecified
 159 ;
 160 ; Add virtual method NAME to CLASS.
 161 ;
 162 ; (method-make-forward! class elm-name methods) -> unspecified
 163 ;
 164 ; Add METHODS to CLASS that pass the "message" onto the object in element
 165 ; ELM-NAME.
 166 ;
 167 ; (method-make-virtual-forward! class elm-name methods) -> unspecified
 168 ;
 169 ; Add virtual METHODS to CLASS that pass the "message" onto the object in
 170 ; element ELM-NAME.
 171 ;
 172 ; (elm-get object elm-name) -> value of element ELM-NAME in OBJ
 173 ;
 174 ; Can only be used in methods.
 175 ;
 176 ; (elm-set! object elm-name new-value) -> unspecified
 177 ;
 178 ; Set element ELM-NAME in OBJECT to NEW-VALUE.
 179 ; Can only be used in methods.
 180 ;
 181 ; (elm-make-getter class elm-name) -> lambda
 182 ;
 183 ; Return lambda to get the value of ELM-NAME in CLASS.
 184 ;
 185 ; (elm-make-setter class elm-name) -> lambda
 186 ;
 187 ; Return lambda to set the value of ELM-NAME in CLASS.
 188 ;
 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.
 197 \f
 198 (define /class-tag "class")
 199 (define /object-tag "object")
 200
 201 ; List of all classes.
 202
 203 (define /class-list '())
 204
 205 ; ??? Were written as a procedures for Hobbit's sake (I think).
 206 (define /object-unspecified #:unspecified)
 207 (define /object-unbound #:unbound)
 208
 209 ; Associative list of classes to be traced.
 210
 211 (define /object-debug-classes #f)
 212
 213 ; Associative list of elements to be traced.
 214
 215 (define /object-debug-elements #f)
 216
 217 ; Associative list of messages to be traced.
 218
 219 (define /object-debug-methods #f)
 220
 221 ; True if error messages are verbose and debugging messages are printed.
 222
 223 (define /object-verbose? #f)
 224
 225 ; Cover fn to set verbosity.
 226
 227 (define (object-set-verbose! verbose?)
 228   (set! /object-verbose? verbose?)
 229 )
 230
 231 ; Signal error if not class/object.
 232
 233 (define (/class-check maybe-class proc-name . extra-text)
 234   (if (not (class? maybe-class))
 235       (apply /object-error
 236              (append! (list proc-name maybe-class "not a class")
 237                       extra-text)))
 238   /object-unspecified
 239 )
 240 (define (/object-check-name maybe-name proc-name . extra-text)
 241   (if (not (symbol? maybe-name))
 242       (apply /object-error
 243              (append! (list proc-name maybe-name) extra-text)))
 244   /object-unspecified
 245 )
 246 (define (/object-check maybe-object proc-name . extra-text)
 247   (if (not (object? maybe-object))
 248       (apply /object-error
 249              (append! (list proc-name maybe-object "not an object")
 250                       extra-text)))
 251   /object-unspecified
 252 )
 253
 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))
 258                         (if (object? x)
 259                             (string-append
 260                              " (class: " (->string (/object-class-name x))
 261                              (if (method-present? x 'get-name)
 262                                  (string-append ", name: "
 263                                                 (->string (send x 'get-name)))
 264                                  "")
 265                              ")")
 266                             "")
 267                         "")
 268          x)
 269 )
 270 \f
 271 ; Low level class operations.
 272
 273 ; Return boolean indicating if X is a class.
 274
 275 (define (class? class)
 276   (and (vector? class) (eq? /class-tag (vector-ref class 0)))
 277 )
 278
 279 ; Accessors.
 280
 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))
 288
 289 (define (/class-set-parents! class parents)
 290   (vector-set! class 2 parents)
 291 )
 292
 293 (define (/class-set-elements! class elm-alist)
 294   (vector-set! class 3 elm-alist)
 295 )
 296
 297 (define (/class-set-methods! class method-alist)
 298   (vector-set! class 4 method-alist)
 299 )
 300
 301 (define (/class-set-all-initial-values! class init-list)
 302   (vector-set! class 5 init-list)
 303 )
 304
 305 (define (/class-set-all-methods! class all-meth-list)
 306   (vector-set! class 6 all-meth-list)
 307 )
 308
 309 (define (/class-set-class-desc! class parent-list)
 310   (vector-set! class 7 parent-list)
 311 )
 312
 313 ; Make a class.
 314 ; The new definition overrides any existing definition.
 315
 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)))
 319     (if list-entry
 320         (set-cdr! list-entry class)
 321         (set! /class-list (acons name class /class-list)))
 322     class)
 323 )
 324
 325 ; Lookup a class given its name.
 326 ; The result is the class or #f if not found.
 327
 328 (define (class-lookup name) (assq-ref /class-list name))
 329
 330 ; Return a list of all direct parent classes of CLASS.
 331
 332 (define (/class-parent-classes class)
 333   ; /class-parents returns the names, we want the actual classes.
 334   (let loop ((parents (/class-parents class))
 335              (result '()))
 336     (if (null? parents)
 337         (reverse! result)
 338         (let ((parent (class-lookup (car parents))))
 339           (if (not parent)
 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)))))
 344 )
 345
 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
 349 ; we don't.
 350
 351 (define (class-name class)
 352   (if (class? class)
 353       (/class-name class)
 354       #f)
 355 )
 356
 357 ; Return a boolean indicating if CLASS or any parent class has
 358 ; multiple inheritance.
 359
 360 (define (/class-mi? class)
 361   (/class-desc-mi? (/class-class-desc class))
 362 )
 363 \f
 364 ; Class descriptor utilities.
 365 ; A class-descriptor is:
 366 ; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
 367
 368 ;(define (/class-desc-make class offset bkptr parents)
 369 ;   (append (list class offset bkptr) parents)
 370 ;)
 371 (define (/class-desc? maybe-class-desc)
 372   (and (pair? maybe-class-desc)
 373        (class? (car maybe-class-desc)))
 374 )
 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)
 385
 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.
 389 ;
 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?
 398
 399 (define (/class-compute-class-desc class offset child)
 400
 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
 406   ; inheritance tree.
 407
 408   (define (compute1 class child base-offset)
 409
 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.
 414
 415     (let ((result (list class #f (cons 999 999) child))
 416           (mi? (> (length (/class-parents class)) 1)))
 417
 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.
 421
 422       (append! result
 423                (let loop ((parents (/class-parents class))
 424                           (parent-descs '())
 425                           (base-offset base-offset))
 426                  (if (null? parents)
 427                      (reverse! parent-descs)
 428                      (let ((parent (class-lookup (car parents))))
 429                        (if (not parent)
 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"))
 433                        (if (and (not mi?)
 434                                 (/class-mi? parent))
 435                            (set! mi? #t))
 436                        (let ((parent-desc (compute1 parent result base-offset)))
 437                          (loop (cdr parents)
 438                                (cons parent-desc parent-descs)
 439                                offset))))))
 440
 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))))
 444       result))
 445
 446   (compute1 class child offset)
 447 )
 448
 449 ; Return the top level class-descriptor of CLASS-DESC.
 450
 451 (define (/class-desc-top class-desc)
 452   (if (/class-desc-child class-desc)
 453       (/class-desc-top (/class-desc-child class-desc))
 454       class-desc)
 455 )
 456
 457 ; Pretty print a class descriptor.
 458
 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)
 465                     (spaces indent port)
 466                     (for-each (lambda (arg) (display arg port))
 467                               args)
 468                     (newline port)))
 469          )
 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)))
 483                                   "-top-"))
 484                      (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
 485                                (/class-desc-parents cd))
 486                      )))
 487       (display "Top level class: " cep)
 488       (display (/class-name (/class-desc-class top-desc)) cep)
 489       (newline cep)
 490       (dump class-desc 0)
 491       ))
 492 )
 493 \f
 494 ; Low level object utilities.
 495
 496 ; Make an object.
 497 ; All elements get initial (or unbound) values.
 498
 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))
 504 )
 505
 506 ; Make an object using VALUES.
 507 ; VALUES must specify all elements in the class (and parent classes).
 508
 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))
 512           class-desc)
 513 )
 514
 515 ; Copy an object.
 516 ; If TOP?, the copy is of the top level object with any specialization
 517 ; discarded.
 518 ; WARNING: A shallow copy is currently done on the elements!
 519
 520 (define (/object-copy obj top?)
 521   (if 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)))
 526 )
 527
 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).
 531
 532 (define (/object-specialize obj class-desc)
 533   (vector (/object-elements obj) class-desc)
 534 )
 535
 536 ; Accessors.
 537
 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))
 543
 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))
 547 )
 548
 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)
 552                new-val)
 553   /object-unspecified
 554 )
 555
 556 ; Return a boolean indicating of OBJ has multiple-inheritance.
 557
 558 (define (/object-mi? obj)
 559   (/class-mi? (/object-top-class obj))
 560 )
 561
 562 ; Return boolean indicating if X is an object.
 563
 564 (define (object? obj)
 565   (and (vector? 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)))
 570 )
 571
 572 ; Return the class of an object.
 573
 574 (define (object-class obj)
 575   (/object-check obj "object-class")
 576   (/object-class obj)
 577 )
 578
 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.
 581
 582 (define (object-class-name obj)
 583   (if (object? obj)
 584       (/object-class-name obj)
 585       #f)
 586 )
 587 \f
 588 ; Class operations.
 589
 590 ; Return the list of initial values for CLASS.
 591 ; The result does not include parent classes.
 592
 593 (define (/class-my-initial-values class)
 594   (map cadr (/class-elements class))
 595 )
 596
 597 ; Initialize class if not already done.
 598 ; FIXME: Need circularity check.  Later.
 599
 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.
 603
 604   (if (not (/class-all-initial-values class))
 605
 606       (begin
 607
 608         ; First pass ensures all parents are initialized.
 609         (for-each /class-check-init!
 610                   (/class-parent-classes class))
 611
 612         ; Next pass initializes the initial value list.
 613         (letrec ((get-inits
 614                   (lambda (class)
 615                     (let ((parents (/class-parent-classes class)))
 616                       (append (apply append (map get-inits parents))
 617                               (/class-my-initial-values class))))))
 618
 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)))
 623
 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))
 628         ))
 629
 630   /object-unspecified
 631 )
 632
 633 ; Make a class.
 634 ;
 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
 640 ; method-make!.
 641
 642 (define (class-make name parents elms methods)
 643   (let ((elm-list #f))
 644
 645     ; Mark elements without initial values as unbound, and
 646     ; compute indices into the element vector (relative to the class's
 647     ; offset).
 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))
 651       (if (null? 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))
 656                            elm-list-tmp)
 657                     (+ index 1)
 658                     (cdr elms))
 659               (loop (acons (car elms)
 660                            (cons /object-unbound (cons #f index))
 661                            elm-list-tmp)
 662                     (+ index 1)
 663                     (cdr elms)))))
 664
 665     (let ((result (/class-make! name parents elm-list methods)))
 666
 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
 674       ; all elements.
 675       (method-make! result 'make!
 676                     (lambda args
 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)
 684                                                    (cdr args)))))
 685
 686       result))
 687 )
 688
 689 ; Create an object of a class CLASS.
 690
 691 (define (new class)
 692   (/class-check class "new")
 693
 694   (if /object-verbose?
 695       (display (string-append "Instantiating class " (/class-name class) ".\n")
 696                (current-error-port)))
 697
 698   (/object-make! class)
 699 )
 700
 701 ; Make a copy of OBJ.
 702 ; WARNING: A shallow copy is done on the elements!
 703
 704 (define (object-copy obj)
 705   (/object-check obj "object-copy")
 706   (/object-copy obj #f)
 707 )
 708
 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!
 712
 713 (define (object-copy-top obj)
 714   (/object-check obj "object-copy-top")
 715   (/object-copy obj #t)
 716 )
 717
 718 ; Utility to define a standard `make!' method.
 719 ; A standard make! method is one in which all it does is initialize
 720 ; fields from args.
 721
 722 (define (method-make-make! class args)
 723   (let ((lambda-expr
 724          (append (list 'lambda (cons 'self args))
 725                  (map (lambda (elm) (list 'elm-set! 'self
 726                                           (list 'quote elm) elm))
 727                       args)
 728                  '(self))))
 729     (method-make! class 'make! (eval1 lambda-expr))
 730     )
 731 )
 732
 733 ; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
 734 ; This puts all that in a cover function.
 735
 736 (define (make class . operands)
 737   (apply send (append (cons (new class) '()) '(make!) operands))
 738 )
 739
 740 ; Return #t if class X is a subclass of BASE-NAME.
 741
 742 (define (/class-subclass? base-name x)
 743   (if (eq? base-name (/class-name x))
 744       #t
 745       (let loop ((parents (/class-parents x)))
 746         (if (null? parents)
 747             #f
 748             (if (/class-subclass? base-name (class-lookup (car parents)))
 749                 #t
 750                 (loop (cdr parents))))))
 751 )
 752
 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.
 756
 757 (define (class-instance? class object)
 758   (/class-check class "class-instance?")
 759   (if (object? object)
 760       (/class-subclass? (/class-name class) (/object-class object))
 761       #f)
 762 )
 763 \f
 764 ; Element operations.
 765
 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.
 770
 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))))
 774     (if elm
 775         (cons class-desc (cddr elm))
 776         (let loop ((parents (/class-desc-parents class-desc)))
 777           (if (null? parents)
 778               #f
 779               (let ((elm (/class-lookup-element (car parents) elm-name)))
 780                 (if elm
 781                     elm
 782                     (loop (cdr parents)))))
 783           ))
 784     )
 785 )
 786
 787 ; Given the result of /class-lookup-element, return the element's delta
 788 ; from base-offset.
 789
 790 (define (/elm-delta index)
 791   (+ (/class-desc-offset-delta (car index))
 792      (cddr index))
 793 )
 794
 795 ; Return a boolean indicating if ELM is bound in OBJ.
 796
 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)))
 802 )
 803
 804 ; Subroutine of elm-get.
 805
 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)))
 809     (if index
 810         (procedure->memoizing-macro
 811          (lambda (exp env)
 812            `(lambda (obj)
 813               (/object-elm-get obj (/object-class-desc obj)
 814                                ,(/elm-delta index)))))
 815         (/object-error "elm-get" self "element not present: " name)))
 816 )
 817
 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)
 824 ; into
 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.
 829
 830 (defmacro elm-get (self name)
 831   (if (eq? self 'self)
 832       `(((/elm-make-method-getter ,self ,name)) ,self)
 833       `(elm-xget ,self ,name))
 834 )
 835
 836 ; Subroutine of elm-set!.
 837
 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)))
 841     (if index
 842         (procedure->memoizing-macro
 843          (lambda (exp env)
 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)))
 848 )
 849
 850 ; Set an element in an object.
 851 ; This can only be used by methods.
 852 ; See the comments for `elm-get'!
 853
 854 (defmacro elm-set! (self name new-val)
 855   (if (eq? self 'self)
 856       `(((/elm-make-method-setter ,self ,name)) ,self ,new-val)
 857       `(elm-xset! ,self ,name ,new-val))
 858 )
 859
 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.
 863
 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?
 868     (if index
 869         (/object-elm-get obj (car index) (/elm-delta index))
 870         (/object-error "elm-xget" obj "element not present: " name)))
 871 )
 872
 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.
 876
 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?
 881     (if index
 882         (/object-elm-set! obj (car index) (/elm-delta index) new-val)
 883         (/object-error "elm-xset!" obj "element not present: " name)))
 884 )
 885
 886 ; Return a boolean indicating if object OBJ has element NAME.
 887
 888 (define (elm-present? obj name)
 889   (/object-check obj "elm-present?")
 890   (->bool (/class-lookup-element (/object-class-desc obj) name))
 891 )
 892
 893 ; Return lambda to get element NAME in CLASS.
 894 ; FIXME: validate name.
 895
 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
 899   ; initialized yet.
 900   (let ((fast-index (delay (/class-lookup-element
 901                             (/class-class-desc class) name))))
 902     (lambda (obj)
 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)))))
 909 )
 910
 911 ; Return lambda to set element NAME in CLASS.
 912 ; FIXME: validate name.
 913
 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
 917   ; initialized yet.
 918   (let ((fast-index (delay (/class-lookup-element
 919                             (/class-class-desc class) name))))
 920     (lambda (obj newval)
 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))))
 927 )
 928
 929 ; Return a list of all elements in OBJ.
 930
 931 (define (elm-list obj)
 932   (cddr (vector->list (/object-elements obj)))
 933 )
 934 \f
 935 ; Method operations.
 936
 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
 940 ; non-virtual.
 941
 942 (define (/method-lookup-next class-desc method-name)
 943   (let loop ((parents (/class-desc-parents class-desc)))
 944     (if (null? parents)
 945         #f
 946         (let ((meth (/method-lookup (car parents) method-name #f)))
 947           (if meth
 948               meth
 949               (loop (cdr parents))))))
 950 )
 951
 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.
 958 ;
 959 ; FIXME: We don't yet implement the method cache.
 960
 961 (define (/method-lookup class-desc method-name virtual?)
 962   (if /object-verbose?
 963       (display (string-append "Looking up method " method-name " in "
 964                               (/class-name (/class-desc-class class-desc)) ".\n")
 965                (current-error-port)))
 966
 967   (let ((meth (assq method-name (/class-methods (/class-desc-class class-desc)))))
 968     (if meth
 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)
 974                        (goal-meth meth))
 975               (if child
 976                   (begin
 977                     (if /object-verbose?
 978                         (display (string-append "Looking up virtual method "
 979                                                 method-name " in "
 980                                                 (/class-name (/class-desc-class child))
 981                                                 ".\n")
 982                                  (current-error-port)))
 983                     (let ((meth (assq method-name (/class-methods (/class-desc-class child)))))
 984                       (if meth
 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))))
 991             ; Non-virtual, done.
 992             (cons class-desc (cddr meth)))
 993         ; Method not found, search parents.
 994         (/method-lookup-next class-desc method-name)))
 995 )
 996
 997 ; Return a boolean indicating if object OBJ has method NAME.
 998
 999 (define (method-present? obj name)
1000   (/object-check obj "method-present?")
1001   (->bool (/method-lookup (/object-class-desc obj) name #f))
1002 )
1003
1004 ; Return method NAME of CLASS or #f if not present.
1005 ; ??? Assumes CLASS has been initialized.
1006
1007 (define (method-proc class name)
1008   (/class-check class "method-proc")
1009   (let ((meth (/method-lookup (/class-class-desc class) name #t)))
1010     (if meth
1011         (cdr meth)
1012         #f))
1013 )
1014
1015 ; Add a method to a class.
1016 ; FIXME: ensure method-name is a symbol
1017
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
1023                                     (cons #f method)
1024                                     (/class-methods class)))
1025   /object-unspecified
1026 )
1027
1028 ; Add a virtual method to a class.
1029 ; FIXME: ensure method-name is a symbol
1030
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
1036                                     (cons #t method)
1037                                     (/class-methods class)))
1038   /object-unspecified
1039 )
1040
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
1046
1047 (define (method-make-forward! class elm-name methods)
1048   (for-each (lambda (method-name)
1049               (method-make!
1050                class method-name
1051                (eval1 `(lambda args
1052                          (apply send
1053                                 (cons (elm-get (car args)
1054                                                (quote ,elm-name))
1055                                       (cons (quote ,method-name)
1056                                             (cdr args))))))))
1057             methods)
1058   /object-unspecified
1059 )
1060
1061 ; Same as method-make-forward! but creates virtual methods.
1062 ; FIXME: ensure elm-name is a symbol
1063
1064 (define (method-make-virtual-forward! class elm-name methods)
1065   (for-each (lambda (method-name)
1066               (method-make-virtual!
1067                class method-name
1068                (eval1 `(lambda args
1069                          (apply send
1070                                 (cons (elm-get (car args)
1071                                                (quote ,elm-name))
1072                                       (cons (quote ,method-name)
1073                                             (cdr args))))))))
1074             methods)
1075   /object-unspecified
1076 )
1077
1078 ; Utility of send, send-next.
1079
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)
1087                                     ""))
1088                               "")
1089                           " class " (object-class-name obj) ".\n")
1090            (current-error-port))
1091   (set! /object-verbose? #t)
1092 )
1093
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.
1099
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 ""))
1104
1105   (let ((class-desc.meth (/method-lookup (/object-class-desc obj)
1106                                          method-name #t)))
1107     (if class-desc.meth
1108         (apply (cdr class-desc.meth)
1109                (cons (/object-specialize obj (car class-desc.meth))
1110                      args))
1111         (/object-error "send" obj "method not supported: " method-name)))
1112 )
1113
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
1116 ; didn't exist.
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?
1120
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 "))
1125
1126   (let ((class-desc.meth (/method-lookup-next (/object-class-desc obj)
1127                                               method-name)))
1128     (if class-desc.meth
1129         (apply (cdr class-desc.meth)
1130                (cons (/object-specialize obj (car class-desc.meth))
1131                      args))
1132         (/object-error "send-next" obj "method not supported: " method-name)))
1133 )
1134 \f
1135 ; Parent operations.
1136
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.
1139
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)))
1143     (if desc
1144         desc
1145         (let loop ((parents parent-descs))
1146           (if (null? parents)
1147               #f
1148               (let ((desc (/class-parent (car parents) parent)))
1149                 (if desc
1150                     desc
1151                     (loop (cdr parents))))))))
1152 )
1153
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.
1158
1159 (define (/class-parent-via-path class-desc parent-path)
1160   (if (null? parent-path)
1161       class-desc
1162       (let ((desc (/class-desc-lookup-parent (car parent-path)
1163                                              (/class-desc-parents class-desc))))
1164         (if desc
1165             (if (null? (cdr parent-path))
1166                 desc
1167                 (/class-parent-via-path (car desc) (cdr parent-path)))
1168             #f)))
1169 )
1170
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.
1177
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
1182                                                                "object-parent"))
1183                                  class))
1184         (else (/object-error "object-parent" class "invalid parent path")))
1185
1186   ; Hobbit generates C code that passes the function
1187   ; /class-parent-via-path or /class-parent, not the appropriate
1188   ; SCM object.
1189 ; (let ((result ((if (or (null? class) (pair? class))
1190 ;                    /class-parent-via-path
1191 ;                    /class-parent)
1192 ;                  obj class)))
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))))
1197     (if result
1198         (/object-specialize obj result)
1199         (/object-error "object-parent" obj "parent not present")))
1200   ; FIXME: should print path in error message.
1201 )
1202
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
1207 ; method lookup).
1208
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)))
1213   /object-unspecified
1214 )
1215
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
1220 ; method lookup).
1221
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)))
1226   /object-unspecified
1227 )
1228 \f
1229 ; Miscellaneous publically accessible utilities.
1230
1231 ; Reset the object system (delete all classes).
1232
1233 (define (object-reset!)
1234   (set! /class-list '())
1235   /object-unspecified
1236 )
1237
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.
1241
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))
1247             (class-list))
1248   (for-each (lambda (class)
1249               (/class-check-init! class))
1250             (class-list))
1251   /object-unspecified
1252 )
1253
1254 ; Return list of all classes.
1255
1256 (define (class-list) (map cdr /class-list))
1257
1258 ; Utility to map over a class and all its parent classes, recursively.
1259
1260 (define (class-map-over-class proc class)
1261   (cons (proc class)
1262         (map (lambda (class) (class-map-over-class proc class))
1263              (/class-parent-classes class)))
1264 )
1265
1266 ; Return class tree of a class or object.
1267
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")))
1275 )
1276
1277 ; Return names of each alist.
1278
1279 (define (/class-alist-names class)
1280   (list (/class-name class)
1281         (map car (/class-elements class))
1282         (map car (/class-methods class)))
1283 )
1284
1285 ; Return complete layout of class-or-object.
1286
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")))
1294 )
1295
1296 ; Like assq but based on the `name' element.
1297 ; WARNING: Slow.
1298
1299 (define (object-assq name obj-list)
1300   (find-first (lambda (o) (eq? (elm-xget o 'name) name))
1301               obj-list)
1302 )
1303
1304 ; Like memq but based on the `name' element.
1305 ; WARNING: Slow.
1306
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)))))
1312 )
1313 \f
1314 ; Misc. internal utilities.
1315
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.
1320
1321 (if (defined? 'vector-copy)
1322     (define /object-vector-copy vector-copy)
1323     (define (/object-vector-copy v) (list->vector (vector->list v)))
1324 )
1325 \f
1326 ; Profiling support
1327
1328 (if (and #f (defined? 'proc-profile))
1329     (begin
1330       (proc-profile elm-get)
1331       (proc-profile elm-xset!)
1332       (proc-profile elm-present?)
1333       (proc-profile /method-lookup)
1334       (proc-profile send)
1335       (proc-profile new)
1336       (proc-profile make)
1337       ))