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 ; 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.
  11 ;
  12 ; NOTE: The original COS supported multiple inheritance.  This does not.
  13 ;
  14 ; Classes look like:
  15 ;
  16 ; #(class-tag
  17 ;   class-name
  18 ;   class-uid ; unique id of class, index into /class-table
  19 ;   parent-name
  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
  24 ;   class-descriptor)
  25 ;
  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.
  29 ;
  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.
  37 ;
  38 ; METHOD-ALIST is an alist of (symbol . procedure) for this class only.
  39 ;
  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).
  45 ;
  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.
  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 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).
  64 ;
  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.
  70 ;
  71 ; -----------------------------------------------------------------------------
  72 ;
  73 ; User visible procs:
  74 ;
  75 ; (class-make name parents elements methods) -> class
  76 ;
  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.
  83 ;
  84 ; (class-list) -> list of all defined classes
  85 ;
  86 ; (class-name class) -> name of CLASS
  87 ;
  88 ; (class-lookup class-name) -> class
  89 ;
  90 ; (class-instance? class object) -> #t if OBJECT is an instance of CLASS
  91 ;
  92 ; (object-class object) -> class of OBJECT
  93 ;
  94 ; (object-class-name object) -> class name of OBJECT
  95 ;
  96 ; (send object method-name . args) -> result of invoking METHOD-NAME
  97 ;
  98 ; (send-next object class-name method-name . args) -> result of invoking next METHOD-NAME
  99 ;
 100 ; (new class) -> instantiate CLASS
 101 ;
 102 ; The object is initialized with values specified when CLASS
 103 ; (and its parent classes) was defined.
 104 ;
 105 ; (vmake class . args) -> instantiate class and initialize it with 'vmake!
 106 ;
 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.
 110 ;
 111 ; (method-vmake! object . args) -> modify OBJECT from ARGS
 112 ;
 113 ; This is the standard 'vmake! method, available for use by user-written
 114 ; 'vmake! methods.
 115 ; ??? Not implemented yet.
 116 ;
 117 ; (make class . args) -> instantiate CLASS and initialize it with 'make!
 118 ;
 119 ; This is shorthand for (send (new class) 'make! arg1 ...).
 120 ; This is a positional form of `new'.
 121 ;
 122 ; (method-make-make! class elm1-name elm2-name ...) -> unspecified
 123 ;
 124 ; Create a 'make! method that sets the specified elements.
 125 ;
 126 ; (object-copy object) -> copy of OBJ
 127 ;
 128 ; ??? Whether to discard the parent or keep it and retain specialization
 129 ; is undecided.
 130 ;
 131 ; (object-copy-top object) -> copy of OBJECT with spec'n discarded
 132 ;
 133 ; (class? foo) -> return #t if FOO is a class
 134 ;
 135 ; (object? foo) -> return #t if FOO is an object
 136 ;
 137 ; (method-make! class name lambda) -> unspecified
 138 ;
 139 ; Add method NAME to CLASS.
 140 ;
 141 ; (method-make-forward! class elm-name methods) -> unspecified
 142 ;
 143 ; Add METHODS to CLASS that pass the "message" onto the object in element
 144 ; ELM-NAME.
 145 ;
 146 ; (elm-get object elm-name) -> value of element ELM-NAME in OBJ
 147 ;
 148 ; Can only be used in methods.
 149 ;
 150 ; (elm-set! object elm-name new-value) -> unspecified
 151 ;
 152 ; Set element ELM-NAME in OBJECT to NEW-VALUE.
 153 ; Can only be used in methods.
 154 ;
 155 ; (elm-make-getter class elm-name) -> lambda
 156 ;
 157 ; Return lambda to get the value of ELM-NAME in CLASS.
 158 ;
 159 ; (elm-make-setter class elm-name) -> lambda
 160 ;
 161 ; Return lambda to set the value of ELM-NAME in CLASS.
 162 ;
 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.
 171 \f
 172 (define /class-tag "class")
 173 (define /object-tag "object")
 174
 175 ;; Alist of all classes.
 176 ;; Each element is (class-name class?-object).
 177 ;; Note that classes are consed unto the front.
 178
 179 (define /class-list '())
 180
 181 ;; Table of all classes, indexed by class-uid.
 182 ;; Note that classes are appended to the end.
 183
 184 (define /class-table '#())
 185
 186 ;; Internal variables to mark their respective properties.
 187 (define /object-unspecified #:unspecified)
 188 (define /object-unbound #:unbound)
 189
 190 ; True if error messages are verbose and debugging messages are printed.
 191
 192 (define /object-verbose? #f)
 193
 194 ; Cover fn to set verbosity.
 195
 196 (define (object-set-verbose! verbose?)
 197   (set! /object-verbose? verbose?)
 198 )
 199
 200 ; Signal error if not class/object.
 201
 202 (define (/class-check maybe-class proc-name . extra-text)
 203   (if (not (class? maybe-class))
 204       (apply /object-error
 205              (append! (list proc-name maybe-class "not a class")
 206                       extra-text)))
 207   /object-unspecified
 208 )
 209
 210 (define (/object-check-name maybe-name proc-name . extra-text)
 211   (if (not (symbol? maybe-name))
 212       (apply /object-error
 213              (append! (list proc-name maybe-name) extra-text)))
 214   /object-unspecified
 215 )
 216
 217 (define (/object-check maybe-object proc-name . extra-text)
 218   (if (not (object? maybe-object))
 219       (apply /object-error
 220              (append! (list proc-name maybe-object "not an object")
 221                       extra-text)))
 222   /object-unspecified
 223 )
 224
 225 ;; Main routine to flag a cos error.
 226 ;; X is any arbitrary Scheme data.
 227
 228 (define (/object-error proc-name x . text)
 229   (error (string-append proc-name ": "
 230                         (apply string-append (map ->string text))
 231                         (if (object? x)
 232                             (string-append
 233                              " (class: " (->string (/object-class-name x))
 234                              (if (method-present? x 'get-name)
 235                                  (string-append ", name: "
 236                                                 (->string (send x 'get-name)))
 237                                  "")
 238                              ")")
 239                             "")
 240                         "")
 241          x)
 242 )
 243 \f
 244 ; Low level class operations.
 245
 246 ; Return boolean indicating if X is a class.
 247
 248 (define (class? class)
 249   (and (vector? class) (eq? /class-tag (vector-ref class 0)))
 250 )
 251
 252 ; Accessors.
 253
 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))
 262
 263 (define (/class-set-uid! class uid)
 264   (vector-set! class 2 uid)
 265 )
 266
 267 (define (/class-set-methods! class method-alist)
 268   (vector-set! class 5 method-alist)
 269 )
 270
 271 (define (/class-set-all-initial-values! class init-list)
 272   (vector-set! class 6 init-list)
 273 )
 274
 275 (define (/class-set-method-cache! class all-meth-list)
 276   (vector-set! class 7 all-meth-list)
 277 )
 278
 279 (define (/class-set-class-desc! class parent-list)
 280   (vector-set! class 8 parent-list)
 281 )
 282
 283 ; Make a class.
 284 ; The new definition overrides any existing definition.
 285
 286 (define (/class-make! name parent-name elements)
 287   (let ((class (vector /class-tag name
 288                        #f ;; uid filled in later
 289                        parent-name elements
 290                        '() ;; methods, none yet
 291                        #f #f #f))
 292         (list-entry (assq name /class-list)))
 293     (if list-entry
 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)
 301                                       (list class))))
 302           (set! /class-list (acons name class /class-list))))
 303     class)
 304 )
 305
 306 ; Lookup a class given its name.
 307 ; The result is the class or #f if not found.
 308
 309 (define (class-lookup name) (assq-ref /class-list name))
 310
 311 ;; Lookup a class given its uid.
 312
 313 (define (/class-lookup-uid uid) (vector-ref /class-table uid))
 314
 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.
 318
 319 (define (/class-parent-classes class)
 320   (if (/class-parent-name class)
 321       (let ((parent (class-lookup (/class-parent-name class))))
 322         (if parent
 323             (list parent)
 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")))
 327       '())
 328 )
 329
 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
 333 ; we don't.
 334
 335 (define (class-name class)
 336   (if (class? class)
 337       (/class-name class)
 338       #f)
 339 )
 340 \f
 341 ; Class descriptor utilities.
 342 ; A class-descriptor is:
 343 ; (class offset child-backpointer [parent-descriptor])
 344
 345 (define (/class-desc? maybe-class-desc)
 346   (and (pair? maybe-class-desc)
 347        (class? (car maybe-class-desc)))
 348 )
 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
 353
 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.
 357 ;
 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.
 364
 365 (define (/class-compute-class-desc class offset child)
 366
 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
 372   ; inheritance tree.
 373
 374   (define (compute1 class child)
 375
 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.
 381
 382     (let ((result (list class 999 child)))
 383
 384       ;; Recurse on the parent.
 385
 386       (if (/class-parent-name class)
 387           (let ((parent (class-lookup (/class-parent-name class))))
 388             (if (not parent)
 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"))
 392
 393             (let ((parent-desc (compute1 parent result)))
 394
 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)))))
 398
 399       (list-set! result 1 offset)
 400       (set! offset (+ offset (length (/class-elements class))))
 401       result))
 402
 403   (compute1 class child)
 404 )
 405
 406 ; Return the top level class-descriptor of CLASS-DESC.
 407
 408 (define (/class-desc-top class-desc)
 409   (if (/class-desc-child class-desc)
 410       (/class-desc-top (/class-desc-child class-desc))
 411       class-desc)
 412 )
 413
 414 ; Pretty print a class descriptor.
 415
 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)
 422                     (spaces indent port)
 423                     (for-each (lambda (arg) (display arg port))
 424                               args)
 425                     (newline port)))
 426          )
 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)))
 436                                   "-top-"))
 437                      (for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
 438                                (/class-desc-parents cd))
 439                      )))
 440       (display "Top level class: " cep)
 441       (display (/class-name (/class-desc-class top-desc)) cep)
 442       (newline cep)
 443       (dump class-desc 0)
 444       ))
 445 )
 446 \f
 447 ; Low level object utilities.
 448
 449 ; Make an object.
 450 ; All elements get initial (or unbound) values.
 451
 452 (define (/object-make! class)
 453   (/class-check-init! class)
 454   (apply vector (append! (list /object-tag
 455                                (/class-name class)
 456                                (/class-uid class))
 457                          (/class-all-initial-values class)))
 458 )
 459
 460 ; Make an object using VALUES.
 461 ; VALUES must specify all elements in the class (and parent classes).
 462
 463 (define (/object-make-with-values! class values)
 464   (/class-check-init! class)
 465   (apply vector (append! (list /object-tag
 466                                (/class-name class)
 467                                (/class-uid class))
 468                          values))
 469 )
 470
 471 ; Copy an object.
 472 ; WARNING: A shallow copy is currently done on the elements!
 473
 474 (define (/object-copy obj)
 475   (/object-vector-copy obj)
 476 )
 477
 478 ; Accessors.
 479
 480 (define (/object-class-name obj) (vector-ref obj 1))
 481 (define (/object-class-uid obj) (vector-ref obj 2))
 482
 483 (define (/object-class-desc obj)
 484   (/class-class-desc (/object-class obj))
 485 )
 486
 487 (define (/object-class obj)
 488   (/class-lookup-uid (/object-class-uid obj))
 489 )
 490
 491 (define (/object-elm-get obj elm-offset)
 492   (vector-ref obj elm-offset)
 493 )
 494
 495 (define (/object-elm-set! obj elm-offset new-val)
 496   (vector-set! obj elm-offset new-val)
 497   /object-unspecified
 498 )
 499
 500 ; Return boolean indicating if X is an object.
 501
 502 (define (object? obj)
 503   (and (vector? obj)
 504        (>= (vector-length obj) 3)
 505        (eq? /object-tag (vector-ref obj 0)))
 506 )
 507
 508 ; Return the class of an object.
 509
 510 (define (object-class obj)
 511   (/object-check obj "object-class")
 512   (/object-class obj)
 513 )
 514
 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.
 517
 518 (define (object-class-name obj)
 519   (if (object? obj)
 520       (/object-class-name obj)
 521       #f)
 522 )
 523 \f
 524 ; Class operations.
 525
 526 ; Return the list of initial values for CLASS.
 527 ; The result does not include parent classes.
 528
 529 (define (/class-my-initial-values class)
 530   (map cadr (/class-elements class))
 531 )
 532
 533 ; Initialize class if not already done.
 534 ; FIXME: Need circularity check.  Later.
 535
 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.
 539
 540   (if (/class-all-initial-values class)
 541
 542       #t ;; nothing to do
 543
 544       (begin
 545
 546         ; First pass ensures all parents are initialized.
 547         (for-each /class-check-init!
 548                   (/class-parent-classes class))
 549
 550         ; Next pass initializes the initial value list.
 551         (letrec ((get-inits
 552                   (lambda (class)
 553                     (let ((parents (/class-parent-classes class)))
 554                       (append (apply append (map get-inits parents))
 555                               (/class-my-initial-values class))))))
 556
 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)))
 561
 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))
 566         ))
 567
 568   /object-unspecified
 569 )
 570
 571 ; Make a class.
 572 ;
 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
 580 ; method-make!.
 581
 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"))
 587
 588   (let ((elm-list #f))
 589
 590     ; Mark elements without initial values as unbound, and
 591     ; compute indices into the element vector (relative to the class's
 592     ; offset).
 593     ; Elements are recorded as (symbol initial-value . vector-index)
 594     (let loop ((elm-list-tmp '()) (index 0) (elms elms))
 595       (if (null? 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)
 600                            elm-list-tmp)
 601                     (+ index 1)
 602                     (cdr elms))
 603               (loop (acons (car elms)
 604                            (cons /object-unbound index)
 605                            elm-list-tmp)
 606                     (+ index 1)
 607                     (cdr elms)))))
 608
 609     (let ((result (/class-make! name
 610                                 (if (null? parents) #f (car parents))
 611                                 elm-list)))
 612
 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
 620       ; all elements.
 621       (method-make! result 'make!
 622                     (lambda args
 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)
 629                                                    (cdr args)))))
 630
 631       result))
 632 )
 633
 634 ; Create an object of a class CLASS.
 635
 636 (define (new class)
 637   (/class-check class "new")
 638
 639   (if /object-verbose?
 640       (display (string-append "Instantiating class " (/class-name class) ".\n")
 641                (current-error-port)))
 642
 643   (/object-make! class)
 644 )
 645
 646 ; Make a copy of OBJ.
 647 ; WARNING: A shallow copy is done on the elements!
 648
 649 (define (object-copy obj)
 650   (/object-check obj "object-copy")
 651   (/object-copy obj)
 652 )
 653
 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.
 658
 659 (define (object-copy-top obj)
 660   (/object-check obj "object-copy-top")
 661   (/object-copy obj)
 662 )
 663
 664 ; Assign object SRC to object DST.
 665 ; They must have the same class.
 666
 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"))
 672
 673   (let ((n (vector-length dst)))
 674     (let loop ((i 0))
 675       (if (< i n)
 676           (begin
 677             (vector-set! dst i (vector-ref src i))
 678             (loop (+ i 1))))))
 679   /object-unspecified
 680 )
 681
 682 ; Utility to define a standard `make!' method.
 683 ; A standard make! method is one in which all it does is initialize
 684 ; fields from args.
 685
 686 (define (method-make-make! class args)
 687   (let ((lambda-expr
 688          (append (list 'lambda (cons 'self args))
 689                  (map (lambda (elm) (list 'elm-set! 'self
 690                                           (list 'quote elm) elm))
 691                       args)
 692                  '(self))))
 693     (method-make! class 'make! (eval1 lambda-expr))
 694     )
 695 )
 696
 697 ; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
 698 ; This puts all that in a cover function.
 699
 700 (define (make class . operands)
 701   (apply send (append (cons (new class) '()) '(make!) operands))
 702 )
 703
 704 ; Return #t if class X is a subclass of BASE-NAME.
 705
 706 (define (/class-subclass? base-name x)
 707   (if (eq? base-name (/class-name x))
 708       #t
 709       (let ((parent-name (/class-parent-name x)))
 710         (if parent-name
 711             (/class-subclass? base-name (class-lookup parent-name))
 712             #f)))
 713 )
 714
 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.
 718
 719 (define (class-instance? class object)
 720   (/class-check class "class-instance?")
 721   (if (object? object)
 722       (/class-subclass? (/class-name class) (/object-class object))
 723       #f)
 724 )
 725 \f
 726 ; Element operations.
 727
 728 ; Lookup an element in a class-desc.
 729 ; The result is elm-index or #f if not found.
 730
 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))))
 734     (if elm
 735         (+ (cddr elm) ;; elm is (name init-value . index)
 736            (/class-desc-offset class-desc))
 737         (let ((parents (/class-desc-parents class-desc)))
 738           (if (null? parents)
 739               #f
 740               (/class-lookup-element (car parents) elm-name)))))
 741 )
 742
 743 ; Return a boolean indicating if ELM-NAME is bound in OBJ.
 744
 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)))
 748     (if index
 749         (not (eq? (/object-elm-get obj index) /object-unbound))
 750         (/object-error "elm-get" self "element not present: " elm-name)))
 751 )
 752
 753 ; Subroutine of elm-get.
 754
 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)))
 758     (if index
 759         (procedure->memoizing-macro
 760          (lambda (exp env)
 761            `(lambda (obj)
 762               (/object-elm-get obj ,index))))
 763         (/object-error "elm-get" self "element not present: " elm-name)))
 764 )
 765
 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)
 772 ; into
 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.
 777
 778 (defmacro elm-get (self elm-name)
 779   (if (eq? self 'self)
 780       `(((/elm-make-method-getter ,self ,elm-name)) ,self)
 781       `(elm-xget ,self ,elm-name))
 782 )
 783
 784 ; Subroutine of elm-set!.
 785
 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)))
 789     (if index
 790         (procedure->memoizing-macro
 791          (lambda (exp env)
 792            `(lambda (obj new-val)
 793               (/object-elm-set! obj ,index new-val))))
 794         (/object-error "elm-set!" self "element not present: " elm-name)))
 795 )
 796
 797 ; Set an element in an object.
 798 ; This can only be used by methods.
 799 ; See the comments for `elm-get'!
 800
 801 (defmacro elm-set! (self elm-name new-val)
 802   (if (eq? self 'self)
 803       `(((/elm-make-method-setter ,self ,elm-name)) ,self ,new-val)
 804       `(elm-xset! ,self ,elm-name ,new-val))
 805 )
 806
 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.
 810
 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)))
 814     (if index
 815         (/object-elm-get obj index)
 816         (/object-error "elm-xget" obj "element not present: " elm-name)))
 817 )
 818
 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.
 822
 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)))
 826     (if index
 827         (/object-elm-set! obj index new-val)
 828         (/object-error "elm-xset!" obj "element not present: " elm-name)))
 829 )
 830
 831 ; Return a boolean indicating if object OBJ has element ELM-NAME.
 832
 833 (define (elm-present? obj elm-name)
 834   (/object-check obj "elm-present?")
 835   (->bool (/class-lookup-element (/object-class-desc obj) elm-name))
 836 )
 837
 838 ; Return lambda to get element ELM-NAME in CLASS.
 839 ; FIXME: validate elm-name.
 840
 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
 844   ; initialized yet.
 845   (let ((fast-index (delay (/class-lookup-element
 846                             (/class-class-desc class) elm-name))))
 847     (lambda (obj)
 848       (let ((index (force fast-index)))
 849         (/object-elm-get obj index))))
 850 )
 851
 852 ; Return lambda to set element ELM-NAME in CLASS.
 853 ; FIXME: validate elm-name.
 854
 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
 858   ; initialized yet.
 859   (let ((fast-index (delay (/class-lookup-element
 860                             (/class-class-desc class) elm-name))))
 861     (lambda (obj newval)
 862       (let ((index (force fast-index)))
 863         (/object-elm-set! obj index newval))))
 864 )
 865 \f
 866 ; Method operations.
 867
 868 ; Lookup the next method in a class.
 869 ; This means begin the search in the parent.
 870
 871 (define (/method-lookup-next class-desc method-name)
 872   (let ((parent-descs (/class-desc-parents class-desc)))
 873     (if (null? parent-descs)
 874         #f
 875         (let ((parent-desc (car parent-descs)))
 876           (/method-lookup parent-desc method-name))))
 877 )
 878
 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.
 882
 883 (define (/method-lookup class-desc method-name)
 884   (if /object-verbose?
 885       (display (string-append "Looking up method " method-name " in "
 886                               (/class-name (/class-desc-class class-desc)) ".\n")
 887                (current-error-port)))
 888
 889   (let ((meth (assq method-name (/class-methods (/class-desc-class class-desc)))))
 890     (if meth
 891         ;; Found.
 892         (cons class-desc (cdr meth))
 893         ; Method not found, search parents.
 894         (/method-lookup-next class-desc method-name)))
 895 )
 896
 897 ; Return a boolean indicating if object OBJ has method NAME.
 898
 899 (define (method-present? obj name)
 900   (/object-check obj "method-present?")
 901   (->bool (/method-lookup (/object-class-desc obj) name))
 902 )
 903
 904 ; Add a method to a class.
 905
 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)))
 913   /object-unspecified
 914 )
 915
 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
 921
 922 (define (method-make-forward! class elm-name methods)
 923   (for-each (lambda (method-name)
 924               (method-make!
 925                class method-name
 926                (eval1 `(lambda args
 927                          (apply send
 928                                 (cons (elm-get (car args)
 929                                                (quote ,elm-name))
 930                                       (cons (quote ,method-name)
 931                                             (cdr args))))))))
 932             methods)
 933   /object-unspecified
 934 )
 935
 936 ; Utility of send, send-next.
 937
 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)
 945                                     ""))
 946                               "")
 947                           " class " (object-class-name obj) ".\n")
 948            (current-error-port))
 949   (set! /object-verbose? #t)
 950 )
 951
 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.
 957
 958 (define (send obj method-name . args)
 959   (/object-check obj "send")
 960   (if /object-verbose? (/object-method-notify obj method-name ""))
 961
 962   (let ((class-desc.meth (/method-lookup (/object-class-desc obj)
 963                                          method-name)))
 964     (if class-desc.meth
 965         (apply (cdr class-desc.meth)
 966                (cons obj args))
 967         (/object-error "send" obj "method not supported: " method-name)))
 968 )
 969
 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
 972 ; didn't exist.
 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.
 982
 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 "))
 986
 987   (let* ((class (class-lookup class-name)) ;; FIXME: slow
 988          (class-desc.meth (/method-lookup-next (/class-class-desc class)
 989                                                method-name)))
 990     (if class-desc.meth
 991         (apply (cdr class-desc.meth)
 992                (cons obj args))
 993         (/object-error "send-next" obj "method not supported: " method-name)))
 994 )
 995 \f
 996 ; Miscellaneous publically accessible utilities.
 997
 998 ; Reset the object system (delete all classes).
 999
1000 (define (object-reset!)
1001   (set! /class-list (list))
1002   (set! /class-table (vector))
1003   /object-unspecified
1004 )
1005
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.
1009
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))
1015             (class-list))
1016   (for-each (lambda (class)
1017               (/class-check-init! class))
1018             (class-list))
1019   /object-unspecified
1020 )
1021
1022 ; Return list of all classes.
1023
1024 (define (class-list) (map cdr /class-list))
1025
1026 ; Utility to map over a class and all its parent classes, recursively.
1027
1028 (define (class-map-over-class proc class)
1029   (cons (proc class)
1030         (map (lambda (class) (class-map-over-class proc class))
1031              (/class-parent-classes class)))
1032 )
1033
1034 ; Return class tree of a class or object.
1035
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")))
1043 )
1044
1045 ; Return names of each alist.
1046
1047 (define (/class-alist-names class)
1048   (list (/class-name class)
1049         (map car (/class-elements class))
1050         (map car (/class-methods class)))
1051 )
1052
1053 ; Return complete layout of class-or-object.
1054
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")))
1062 )
1063
1064 ; Like assq but based on the `name' element.
1065 ; WARNING: Slow.
1066
1067 (define (object-assq name obj-list)
1068   (find-first (lambda (o) (eq? (elm-xget o 'name) name))
1069               obj-list)
1070 )
1071
1072 ; Like memq but based on the `name' element.
1073 ; WARNING: Slow.
1074
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)))))
1080 )
1081 \f
1082 ; Misc. internal utilities.
1083
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.
1087
1088 (if (defined? 'vector-copy)
1089     (define /object-vector-copy vector-copy)
1090     (define (/object-vector-copy v) (list->vector (vector->list v)))
1091 )