oop/goops.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 \f
  21
  22 ;;;; This software is a derivative work of other copyrighted softwares; the
  23 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  24 ;;;;
  25 ;;;; This file is based upon stklos.stk from the STk distribution by
  26 ;;;; Erick Gallesio <eg@unice.fr>.
  27 ;;;;
  28
  29 (define-module (oop goops)
  30   :use-module (oop goops goopscore)
  31   :use-module (oop goops util)
  32   :use-module (oop goops dispatch)
  33   :use-module (oop goops compile)
  34   :no-backtrace
  35   )
  36
  37 (export                   ; Define the exported symbols of this file
  38     goops-version is-a?
  39     ensure-metaclass ensure-metaclass-with-supers
  40     define-class   class make-class
  41     define-generic make-generic ensure-generic
  42     define-accessor make-accessor ensure-accessor
  43     define-method make-method method add-method!
  44     object-eqv? object-equal?
  45     class-slot-ref class-slot-set! slot-unbound slot-missing
  46     slot-definition-name  slot-definition-options slot-definition-allocation
  47     slot-definition-getter slot-definition-setter slot-definition-accessor
  48     slot-definition-init-value slot-definition-init-form
  49     slot-definition-init-thunk slot-definition-init-keyword
  50     slot-init-function class-slot-definition
  51     method-source
  52     compute-cpl compute-std-cpl compute-get-n-set compute-slots
  53     compute-getter-method compute-setter-method
  54     allocate-instance initialize make-instance make
  55     no-next-method  no-applicable-method no-method
  56     change-class update-instance-for-different-class
  57     shallow-clone deep-clone
  58     class-redefinition
  59     apply-generic apply-method apply-methods
  60     compute-applicable-methods %compute-applicable-methods
  61     method-more-specific? sort-applicable-methods
  62     class-subclasses class-methods
  63     goops-error
  64     min-fixnum max-fixnum
  65 )
  66
  67 ;;; *fixme* Should go into goops.c
  68
  69 (export
  70     instance?  slot-ref-using-class
  71     slot-set-using-class! slot-bound-using-class?
  72     slot-exists-using-class? slot-ref slot-set! slot-bound? class-of
  73     class-name class-direct-supers class-direct-subclasses
  74     class-direct-methods class-direct-slots class-precedence-list
  75     class-slots class-environment
  76     generic-function-name
  77     generic-function-methods method-generic-function method-specializers
  78     primitive-generic-generic enable-primitive-generic!
  79     method-procedure accessor-method-slot-definition
  80     slot-exists? make find-method get-keyword
  81     %logand)
  82
  83 \f
  84 (define min-fixnum (- (expt 2 29)))
  85
  86 (define max-fixnum (- (expt 2 29) 1))
  87
  88 ;;
  89 ;; goops-error
  90 ;;
  91 (define (goops-error format-string . args)
  92   (save-stack)
  93   (scm-error 'goops-error #f format-string args '()))
  94
  95 ;;
  96 ;; is-a?
  97 ;;
  98 (define (is-a? obj class)
  99   (and (memq class (class-precedence-list (class-of obj))) #t))
 100
 101
 102 ;;;
 103 ;;; {Meta classes}
 104 ;;;
 105
 106 (define ensure-metaclass-with-supers
 107   (let ((table-of-metas '()))
 108     (lambda (meta-supers)
 109       (let ((entry (assoc meta-supers table-of-metas)))
 110         (if entry
 111             ;; Found a previously created metaclass
 112             (cdr entry)
 113             ;; Create a new meta-class which inherit from "meta-supers"
 114             (let ((new (make <class> #:dsupers meta-supers
 115                                      #:slots   '()
 116                                      #:name   (gensym "metaclass"))))
 117               (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
 118               new))))))
 119
 120 (define (ensure-metaclass supers env)
 121   (if (null? supers)
 122       <class>
 123       (let* ((all-metas (map (lambda (x) (class-of x)) supers))
 124              (all-cpls  (apply append
 125                                (map (lambda (m)
 126                                       (cdr (class-precedence-list m)))
 127                                     all-metas)))
 128              (needed-metas '()))
 129         ;; Find the most specific metaclasses.  The new metaclass will be
 130         ;; a subclass of these.
 131         (for-each
 132          (lambda (meta)
 133            (if (and (not (member meta all-cpls))
 134                       (not (member meta needed-metas)))
 135              (set! needed-metas (append needed-metas (list meta)))))
 136          all-metas)
 137         ;; Now return a subclass of the metaclasses we found.
 138         (if (null? (cdr needed-metas))
 139             (car needed-metas)  ; If there's only one, just use it.
 140             (ensure-metaclass-with-supers needed-metas)))))
 141
 142 ;;;
 143 ;;; {Classes}
 144 ;;;
 145
 146 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 147 ;;;
 148 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 149 ;;;   OPTION ::= KEYWORD VALUE
 150 ;;;
 151 (define (define-class-pre-definition keyword exp env)
 152   (case keyword
 153     ((#:getter #:setter)
 154      (if (defined? exp env)
 155          `(define ,exp (ensure-generic ,exp ',exp))
 156          `(define ,exp (make-generic ',exp))))
 157     ((#:accessor)
 158      (if (defined? exp env)
 159          `(define ,exp (ensure-accessor ,exp ',exp))
 160          `(define ,exp (make-accessor ',exp))))
 161     (else #f)))
 162
 163 ;;; This code should be implemented in C.
 164 ;;;
 165 (define define-class
 166   (letrec (;; Some slot options require extra definitions to be made.
 167            ;; In particular, we want to make sure that the generic
 168            ;; function objects which represent accessors exist
 169            ;; before `make-class' tries to add methods to them.
 170            ;;
 171            ;; Postpone error handling to class macro.
 172            ;;
 173            (pre-definitions
 174             (lambda (slots env)
 175               (do ((slots slots (cdr slots))
 176                    (definitions '()
 177                      (if (pair? (car slots))
 178                          (do ((options (cdar slots) (cddr options))
 179                               (definitions definitions
 180                                 (cond ((not (symbol? (cadr options)))
 181                                        definitions)
 182                                       ((define-class-pre-definition
 183                                          (car options)
 184                                          (cadr options)
 185                                          env)
 186                                        => (lambda (definition)
 187                                             (cons definition definitions)))
 188                                       (else definitions))))
 189                              ((not (and (pair? options)
 190                                         (pair? (cdr options))))
 191                               definitions))
 192                          definitions)))
 193                   ((or (not (pair? slots))
 194                        (keyword? (car slots)))
 195                    (reverse definitions)))))
 196
 197            ;; Syntax
 198            (name cadr)
 199            (slots cdddr))
 200
 201     (procedure->macro
 202       (lambda (exp env)
 203         (cond ((not (top-level-env? env))
 204                (goops-error "define-class: Only allowed at top level"))
 205               ((not (and (list? exp) (>= (length exp) 3)))
 206                (goops-error "missing or extra expression"))
 207               (else
 208                (let ((name (name exp)))
 209                  `(begin
 210                     ;; define accessors
 211                     ,@(pre-definitions (slots exp) env)
 212
 213                     ,(if (defined? name env)
 214
 215                          ;; redefine an old class
 216                          `(define ,name
 217                             (let ((old ,name)
 218                                   (new (class ,@(cddr exp) #:name ',name)))
 219                               (if (and (is-a? old <class>)
 220                                        ;; Prevent redefinition of non-objects
 221                                        (memq <object>
 222                                              (class-precedence-list old)))
 223                                   (class-redefinition old new)
 224                                   new)))
 225
 226                          ;; define a new class
 227                          `(define ,name
 228                             (class ,@(cddr exp) #:name ',name)))))))))))
 229
 230 (define standard-define-class define-class)
 231
 232 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 233 ;;;
 234 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 235 ;;;   OPTION ::= KEYWORD VALUE
 236 ;;;
 237 (define class
 238   (letrec ((slot-option-keyword car)
 239            (slot-option-value cadr)
 240            (process-slot-options
 241             (lambda (options)
 242               (let loop ((options options)
 243                          (res '()))
 244                 (cond ((null? options)
 245                        (reverse res))
 246                       ((null? (cdr options))
 247                        (goops-error "malformed slot option list"))
 248                       ((not (keyword? (slot-option-keyword options)))
 249                        (goops-error "malformed slot option list"))
 250                       (else
 251                        (case (slot-option-keyword options)
 252                          ((#:init-form)
 253                           (loop (cddr options)
 254                                 (append (list `(lambda ()
 255                                                  ,(slot-option-value options))
 256                                               #:init-thunk
 257                                               (list 'quote
 258                                                     (slot-option-value options))
 259                                               #:init-form)
 260                                         res)))
 261                          (else
 262                           (loop (cddr options)
 263                                 (cons (cadr options)
 264                                       (cons (car options)
 265                                             res)))))))))))
 266
 267     (procedure->memoizing-macro
 268       (let ((supers cadr)
 269             (slots cddr)
 270             (options cdddr))
 271         (lambda (exp env)
 272           (cond ((not (and (list? exp) (>= (length exp) 2)))
 273                  (goops-error "missing or extra expression"))
 274                 ((not (list? (supers exp)))
 275                  (goops-error "malformed superclass list: ~S" (supers exp)))
 276                 (else
 277                  (let ((slot-defs (cons #f '())))
 278                    (do ((slots (slots exp) (cdr slots))
 279                         (defs slot-defs (cdr defs)))
 280                        ((or (null? slots)
 281                             (keyword? (car slots)))
 282                         `(make-class
 283                           ;; evaluate super class variables
 284                           (list ,@(supers exp))
 285                           ;; evaluate slot definitions, except the slot name!
 286                           (list ,@(cdr slot-defs))
 287                           ;; evaluate class options
 288                           ,@slots
 289                           ;; place option last in case someone wants to
 290                           ;; pass a different value
 291                           #:environment ',env))
 292                      (set-cdr!
 293                       defs
 294                       (list (if (pair? (car slots))
 295                                 `(list ',(slot-definition-name (car slots))
 296                                        ,@(process-slot-options
 297                                           (slot-definition-options
 298                                            (car slots))))
 299                                 `(list ',(car slots))))))))))))))
 300
 301 (define (make-class supers slots . options)
 302   (let ((env (or (get-keyword #:environment options #f)
 303                  (top-level-env))))
 304     (let* ((name (get-keyword #:name options (make-unbound)))
 305            (supers (if (not (or-map (lambda (class)
 306                                       (memq <object>
 307                                             (class-precedence-list class)))
 308                                     supers))
 309                        (append supers (list <object>))
 310                        supers))
 311            (metaclass (or (get-keyword #:metaclass options #f)
 312                           (ensure-metaclass supers env))))
 313
 314       ;; Verify that all direct slots are different and that we don't inherit
 315       ;; several time from the same class
 316       (let ((tmp1 (find-duplicate supers))
 317             (tmp2 (find-duplicate (map slot-definition-name slots))))
 318         (if tmp1
 319             (goops-error "make-class: super class ~S is duplicate in class ~S"
 320                          tmp1 name))
 321         (if tmp2
 322             (goops-error "make-class: slot ~S is duplicate in class ~S"
 323                          tmp2 name)))
 324
 325       ;; Everything seems correct, build the class
 326       (apply make metaclass
 327              #:dsupers supers
 328              #:slots slots
 329              #:name name
 330              #:environment env
 331              options))))
 332
 333 ;;;
 334 ;;; {Generic functions and accessors}
 335 ;;;
 336
 337 (define define-generic
 338   (procedure->macro
 339     (lambda (exp env)
 340       (let ((name (cadr exp)))
 341         (cond ((not (symbol? name))
 342                (goops-error "bad generic function name: ~S" name))
 343               ((defined? name env)
 344                `(define ,name
 345                   (if (is-a? ,name <generic>)
 346                       (make <generic> #:name ',name)
 347                       (ensure-generic ,name ',name))))
 348               (else
 349                `(define ,name (make <generic> #:name ',name))))))))
 350
 351 (define (make-generic . name)
 352   (let ((name (and (pair? name) (car name))))
 353     (make <generic> #:name name)))
 354
 355 (define (ensure-generic old-definition . name)
 356   (let ((name (and (pair? name) (car name))))
 357     (cond ((is-a? old-definition <generic>) old-definition)
 358           ((procedure-with-setter? old-definition)
 359            (make <generic-with-setter>
 360                  #:name name
 361                  #:default (procedure old-definition)
 362                  #:setter (setter old-definition)))
 363           ((procedure? old-definition)
 364            (make <generic> #:name name #:default old-definition))
 365           (else (make <generic> #:name name)))))
 366
 367 (define define-accessor
 368   (procedure->macro
 369     (lambda (exp env)
 370       (let ((name (cadr exp)))
 371         (cond ((not (symbol? name))
 372                (goops-error "bad accessor name: ~S" name))
 373               ((defined? name env)
 374                `(define ,name
 375                   (if (and (is-a? ,name <generic-with-setter>)
 376                            (is-a? (setter ,name) <generic>))
 377                       (make-accessor ',name)
 378                       (ensure-accessor ,name ',name))))
 379               (else
 380                `(define ,name (make-accessor ',name))))))))
 381
 382 (define (make-setter-name name)
 383   (string->symbol (string-append "setter:" (symbol->string name))))
 384
 385 (define (make-accessor . name)
 386   (let ((name (and (pair? name) (car name))))
 387     (make <generic-with-setter>
 388           #:name name
 389           #:setter (make <generic>
 390                          #:name (and name (make-setter-name name))))))
 391
 392 (define (ensure-accessor proc . name)
 393   (let ((name (and (pair? name) (car name))))
 394     (cond ((is-a? proc <generic-with-setter>)
 395            (if (is-a? (setter proc) <generic>)
 396                proc
 397                (upgrade-generic-with-setter proc (setter proc))))
 398           ((is-a? proc <generic>)
 399            (upgrade-generic-with-setter proc (make-generic name)))
 400           ((procedure-with-setter? proc)
 401            (make <generic-with-setter>
 402                  #:name name
 403                  #:default (procedure proc)
 404                  #:setter (ensure-generic (setter proc) name)))
 405           ((procedure? proc)
 406            (ensure-accessor (ensure-generic proc name) name))
 407           (else
 408            (make-accessor name)))))
 409
 410 (define (upgrade-generic-with-setter generic setter)
 411   (let ((methods (generic-function-methods generic))
 412         (gws (make <generic-with-setter>
 413                    #:name (generic-function-name generic)
 414                    #:setter setter)))
 415     ;; Steal old methods
 416     (for-each (lambda (method)
 417                 (slot-set! method 'generic-function gws))
 418               methods)
 419     (slot-set! gws 'methods methods)
 420     gws))
 421
 422 ;;;
 423 ;;; {Methods}
 424 ;;;
 425
 426 (define define-method
 427   (procedure->memoizing-macro
 428     (lambda (exp env)
 429       (let ((name (cadr exp)))
 430         (if (and (pair? name)
 431                  (eq? (car name) 'setter)
 432                  (pair? (cdr name))
 433                  (symbol? (cadr name))
 434                  (null? (cddr name)))
 435             (let ((name (cadr name)))
 436               (cond ((not (symbol? name))
 437                      (goops-error "bad method name: ~S" name))
 438                     ((defined? name env)
 439                      `(begin
 440                         ;; *fixme* Temporary hack for the current module system
 441                         (if (not ,name)
 442                             (define-generic ,name))
 443                         (add-method! (setter ,name) (method ,@(cddr exp)))))
 444                     (else
 445                      `(begin
 446                         (define-accessor ,name)
 447                         (add-method! (setter ,name) (method ,@(cddr exp)))))))
 448             (cond ((pair? name)
 449                    ;; Convert new syntax to old
 450                    `(define-method ,(car name) ,(cdr name) ,@(cddr exp)))
 451                   ((not (symbol? name))
 452                    (goops-error "bad method name: ~S" name))
 453                   ((defined? name env)
 454                    `(begin
 455                       ;; *fixme* Temporary hack for the current module system
 456                       (if (not ,name)
 457                           (define-generic ,name))
 458                       (add-method! ,name (method ,@(cddr exp)))))
 459                   (else
 460                    `(begin
 461                       (define-generic ,name)
 462                       (add-method! ,name (method ,@(cddr exp)))))))))))
 463
 464 (define (make-method specializers procedure)
 465   (make <method>
 466         #:specializers specializers
 467         #:procedure procedure))
 468
 469 (define method
 470   (letrec ((specializers
 471             (lambda (ls)
 472               (cond ((null? ls) (list ls))
 473                     ((pair? ls) (cons (if (pair? (car ls))
 474                                           (cadar ls)
 475                                           '<top>)
 476                                       (specializers (cdr ls))))
 477                     (else '(<top>)))))
 478            (formals
 479             (lambda (ls)
 480               (if (pair? ls)
 481                   (cons (if (pair? (car ls)) (caar ls) (car ls))
 482                         (formals (cdr ls)))
 483                   ls))))
 484     (procedure->memoizing-macro
 485       (lambda (exp env)
 486         (let ((args (cadr exp))
 487               (body (cddr exp)))
 488           `(make <method>
 489                  #:specializers (list* ,@(specializers args))
 490                  #:procedure (lambda ,(formals args)
 491                                ,@(if (null? body)
 492                                      (list *unspecified*)
 493                                      body))))))))
 494
 495 ;;;
 496 ;;; {add-method!}
 497 ;;;
 498
 499 (define (add-method-in-classes! m)
 500   ;; Add method in all the classes which appears in its specializers list
 501   (for-each* (lambda (x)
 502                (let ((dm (class-direct-methods x)))
 503                  (if (not (memv m dm))
 504                      (slot-set! x 'direct-methods (cons m dm)))))
 505              (method-specializers m)))
 506
 507 (define (remove-method-in-classes! m)
 508   ;; Remove method in all the classes which appears in its specializers list
 509   (for-each* (lambda (x)
 510                (slot-set! x
 511                           'direct-methods
 512                           (delv! m (class-direct-methods x))))
 513              (method-specializers m)))
 514
 515 (define (compute-new-list-of-methods gf new)
 516   (let ((new-spec (method-specializers new))
 517         (methods  (generic-function-methods gf)))
 518     (let loop ((l methods))
 519       (if (null? l)
 520           (cons new methods)
 521           (if (equal? (method-specializers (car l)) new-spec)
 522               (begin
 523                 ;; This spec. list already exists. Remove old method from dependents
 524                 (remove-method-in-classes! (car l))
 525                 (set-car! l new)
 526                 methods)
 527               (loop (cdr l)))))))
 528
 529 (define (internal-add-method! gf m)
 530   (slot-set! m  'generic-function gf)
 531   (slot-set! gf 'methods (compute-new-list-of-methods gf m))
 532   (let ((specializers (slot-ref m 'specializers)))
 533     (slot-set! gf 'n-specialized
 534                (let ((n-specialized (slot-ref gf 'n-specialized)))
 535                  ;; The magnitude indicates # specializers.
 536                  ;; A negative value indicates that at least one
 537                  ;; method has rest arguments. (Ugly but effective
 538                  ;; space optimization saving one slot in GF objects.)
 539                  (cond ((negative? n-specialized)
 540                         (- (max (+ 1 (length* specializers))
 541                                 (abs n-specialized))))
 542                        ((list? specializers)
 543                         (max (length specializers)
 544                              n-specialized))
 545                        (else
 546                         (- (+ 1 (max (length* specializers)
 547                                      n-specialized)))))
 548                  )))
 549   (%invalidate-method-cache! gf)
 550   (add-method-in-classes! m)
 551   *unspecified*)
 552
 553 (define-generic add-method!)
 554
 555 (internal-add-method! add-method!
 556                       (make <method>
 557                         #:specializers (list <generic> <method>)
 558                         #:procedure internal-add-method!))
 559
 560 (define-method add-method! ((proc <procedure>) (m <method>))
 561   (if (generic-capability? proc)
 562       (begin
 563         (enable-primitive-generic! proc)
 564         (add-method! proc m))
 565       (next-method)))
 566
 567 (define-method add-method! ((pg <primitive-generic>) (m <method>))
 568   (add-method! (primitive-generic-generic pg) m))
 569
 570 (define-method add-method! (obj (m <method>))
 571   (goops-error "~S is not a valid generic function" obj))
 572
 573 ;;;
 574 ;;; {Access to meta objects}
 575 ;;;
 576
 577 ;;;
 578 ;;; Methods
 579 ;;;
 580 (define-method method-source ((m <method>))
 581   (let* ((spec (map* class-name (slot-ref m 'specializers)))
 582          (proc (procedure-source (slot-ref m 'procedure)))
 583          (args (cadr proc))
 584          (body (cddr proc)))
 585     (cons 'method
 586           (cons (map* list args spec)
 587                 body))))
 588
 589 ;;;
 590 ;;; Slots
 591 ;;;
 592 (define slot-definition-name car)
 593
 594 (define slot-definition-options cdr)
 595
 596 (define (slot-definition-allocation s)
 597   (get-keyword #:allocation (cdr s) #:instance))
 598
 599 (define (slot-definition-getter s)
 600   (get-keyword #:getter (cdr s) #f))
 601
 602 (define (slot-definition-setter s)
 603   (get-keyword #:setter (cdr s) #f))
 604
 605 (define (slot-definition-accessor s)
 606   (get-keyword #:accessor (cdr s) #f))
 607
 608 (define (slot-definition-init-value s)
 609   ;; can be #f, so we can't use #f as non-value
 610   (get-keyword #:init-value (cdr s) (make-unbound)))
 611
 612 (define (slot-definition-init-form s)
 613   (get-keyword #:init-form (cdr s) (make-unbound)))
 614
 615 (define (slot-definition-init-thunk s)
 616   (get-keyword #:init-thunk (cdr s) #f))
 617
 618 (define (slot-definition-init-keyword s)
 619   (get-keyword #:init-keyword (cdr s) #f))
 620
 621 (define (class-slot-definition class slot-name)
 622   (assq slot-name (class-slots class)))
 623
 624 (define (slot-init-function class slot-name)
 625   (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
 626
 627
 628 ;;;
 629 ;;; {Standard methods used by the C runtime}
 630 ;;;
 631
 632 ;;; Methods to compare objects
 633 ;;;
 634
 635 (define-method object-eqv? (x y)    #f)
 636 (define-method object-equal? (x y)  (eqv? x y))
 637
 638 ;;;
 639 ;;; methods to display/write an object
 640 ;;;
 641
 642 ;     Code for writing objects must test that the slots they use are
 643 ;     bound. Otherwise a slot-unbound method will be called and will
 644 ;     conduct to an infinite loop.
 645
 646 ;; Write
 647 (define (display-address o file)
 648   (display (number->string (object-address o) 16) file))
 649
 650 (define-method write (o file)
 651   (display "#<instance " file)
 652   (display-address o file)
 653   (display #\> file))
 654
 655 (define write-object (primitive-generic-generic write))
 656
 657 (define-method write ((o <object>) file)
 658   (let ((class (class-of o)))
 659     (if (slot-bound? class 'name)
 660         (begin
 661           (display "#<" file)
 662           (display (class-name class) file)
 663           (display #\space file)
 664           (display-address o file)
 665           (display #\> file))
 666         (next-method))))
 667
 668 (define-method write ((o <foreign-object>) file)
 669   (let ((class (class-of o)))
 670     (if (slot-bound? class 'name)
 671         (begin
 672           (display "#<foreign-object " file)
 673           (display (class-name class) file)
 674           (display #\space file)
 675           (display-address o file)
 676           (display #\> file))
 677         (next-method))))
 678
 679 (define-method write ((class <class>) file)
 680   (let ((meta (class-of class)))
 681     (if (and (slot-bound? class 'name)
 682              (slot-bound? meta 'name))
 683         (begin
 684           (display "#<" file)
 685           (display (class-name meta) file)
 686           (display #\space file)
 687           (display (class-name class) file)
 688           (display #\space file)
 689           (display-address class file)
 690           (display #\> file))
 691         (next-method))))
 692
 693 (define-method write ((gf <generic>) file)
 694   (let ((meta (class-of gf)))
 695     (if (and (slot-bound? meta 'name)
 696              (slot-bound? gf 'methods))
 697         (begin
 698           (display "#<" file)
 699           (display (class-name meta) file)
 700           (let ((name (generic-function-name gf)))
 701             (if name
 702                 (begin
 703                   (display #\space file)
 704                   (display name file))))
 705           (display " (" file)
 706           (display (length (generic-function-methods gf)) file)
 707           (display ")>" file))
 708         (next-method))))
 709
 710 (define-method write ((o <method>) file)
 711   (let ((meta (class-of o)))
 712     (if (and (slot-bound? meta 'name)
 713              (slot-bound? o 'specializers))
 714         (begin
 715           (display "#<" file)
 716           (display (class-name meta) file)
 717           (display #\space file)
 718           (display (map* (lambda (spec)
 719                            (if (slot-bound? spec 'name)
 720                                (slot-ref spec 'name)
 721                                spec))
 722                          (method-specializers o))
 723                    file)
 724           (display #\space file)
 725           (display-address o file)
 726           (display #\> file))
 727         (next-method))))
 728
 729 ;; Display (do the same thing as write by default)
 730 (define-method display (o file)
 731   (write-object o file))
 732
 733 ;;;
 734 ;;; slot access
 735 ;;;
 736
 737 (define (class-slot-g-n-s class slot-name)
 738   (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
 739          (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
 740                           (slot-missing class slot-name)))))
 741     (if (not (memq (slot-definition-allocation this-slot)
 742                    '(#:class #:each-subclass)))
 743         (slot-missing class slot-name))
 744     g-n-s))
 745
 746 (define (class-slot-ref class slot)
 747   (let ((x ((car (class-slot-g-n-s class slot)) #f)))
 748     (if (unbound? x)
 749         (slot-unbound class slot)
 750         x)))
 751
 752 (define (class-slot-set! class slot value)
 753   ((cadr (class-slot-g-n-s class slot)) #f value))
 754
 755 (define-method slot-unbound ((c <class>) (o <object>) s)
 756   (goops-error "Slot `~S' is unbound in object ~S" s o))
 757
 758 (define-method slot-unbound ((c <class>) s)
 759   (goops-error "Slot `~S' is unbound in class ~S" s c))
 760
 761 (define-method slot-unbound ((o <object>))
 762   (goops-error "Unbound slot in object ~S" o))
 763
 764 (define-method slot-missing ((c <class>) (o <object>) s)
 765   (goops-error "No slot with name `~S' in object ~S" s o))
 766
 767 (define-method slot-missing ((c <class>) s)
 768   (goops-error "No class slot with name `~S' in class ~S" s c))
 769
 770
 771 (define-method slot-missing ((c <class>) (o <object>) s value)
 772   (slot-missing c o s))
 773
 774 ;;; Methods for the possible error we can encounter when calling a gf
 775
 776 (define-method no-next-method ((gf <generic>) args)
 777   (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
 778
 779 (define-method no-applicable-method ((gf <generic>) args)
 780   (goops-error "No applicable method for ~S in call ~S"
 781                gf (cons (generic-function-name gf) args)))
 782
 783 (define-method no-method ((gf <generic>) args)
 784   (goops-error "No method defined for ~S"  gf))
 785
 786 ;;;
 787 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
 788 ;;;
 789
 790 (define-method shallow-clone ((self <object>))
 791   (let ((clone (%allocate-instance (class-of self) '()))
 792         (slots (map slot-definition-name
 793                     (class-slots (class-of self)))))
 794     (for-each (lambda (slot)
 795                 (if (slot-bound? self slot)
 796                     (slot-set! clone slot (slot-ref self slot))))
 797               slots)
 798     clone))
 799
 800 (define-method deep-clone  ((self <object>))
 801   (let ((clone (%allocate-instance (class-of self) '()))
 802         (slots (map slot-definition-name
 803                     (class-slots (class-of self)))))
 804     (for-each (lambda (slot)
 805                 (if (slot-bound? self slot)
 806                     (slot-set! clone slot
 807                                (let ((value (slot-ref self slot)))
 808                                  (if (instance? value)
 809                                      (deep-clone value)
 810                                      value)))))
 811               slots)
 812     clone))
 813
 814 ;;;
 815 ;;; {Class redefinition utilities}
 816 ;;;
 817
 818 ;;; (class-redefinition OLD NEW)
 819 ;;;
 820
 821 ;;; Has correct the following conditions:
 822
 823 ;;; Methods
 824 ;;;
 825 ;;; 1. New accessor specializers refer to new header
 826 ;;;
 827 ;;; Classes
 828 ;;;
 829 ;;; 1. New class cpl refers to the new class header
 830 ;;; 2. Old class header exists on old super classes direct-subclass lists
 831 ;;; 3. New class header exists on new super classes direct-subclass lists
 832
 833 (define-method class-redefinition ((old <class>) (new <class>))
 834   ;; Work on direct methods:
 835   ;;            1. Remove accessor methods from the old class
 836   ;;            2. Patch the occurences of new in the specializers by old
 837   ;;            3. Displace the methods from old to new
 838   (remove-class-accessors! old)                                 ;; -1-
 839   (let ((methods (class-direct-methods new)))
 840     (for-each (lambda (m)
 841                  (update-direct-method! m new old))     ;; -2-
 842               methods)
 843     (slot-set! new
 844                'direct-methods
 845                (append methods (class-direct-methods old))))
 846
 847   ;; Substitute old for new in new cpl
 848   (set-car! (slot-ref new 'cpl) old)
 849
 850   ;; Remove the old class from the direct-subclasses list of its super classes
 851   (for-each (lambda (c) (slot-set! c 'direct-subclasses
 852                                    (delv! old (class-direct-subclasses c))))
 853             (class-direct-supers old))
 854
 855   ;; Replace the new class with the old in the direct-subclasses of the supers
 856   (for-each (lambda (c)
 857               (slot-set! c 'direct-subclasses
 858                          (cons old (delv! new (class-direct-subclasses c)))))
 859             (class-direct-supers new))
 860
 861   ;; Swap object headers
 862   (%modify-class old new)
 863
 864   ;; Now old is NEW!
 865
 866   ;; Redefine all the subclasses of old to take into account modification
 867   (for-each
 868        (lambda (c)
 869          (update-direct-subclass! c new old))
 870        (class-direct-subclasses new))
 871
 872   ;; Invalidate class so that subsequent instances slot accesses invoke
 873   ;; change-object-class
 874   (slot-set! new 'redefined old)
 875   (%invalidate-class new) ;must come after slot-set!
 876
 877   old)
 878
 879 ;;;
 880 ;;; remove-class-accessors!
 881 ;;;
 882
 883 (define-method remove-class-accessors! ((c <class>))
 884   (for-each (lambda (m)
 885               (if (is-a? m <accessor-method>)
 886                   (remove-method-in-classes! m)))
 887             (class-direct-methods c)))
 888
 889 ;;;
 890 ;;; update-direct-method!
 891 ;;;
 892
 893 (define-method update-direct-method! ((m  <method>)
 894                                       (old <class>)
 895                                       (new <class>))
 896   (let loop ((l (method-specializers m)))
 897     ;; Note: the <top> in dotted list is never used.
 898     ;; So we can work as if we had only proper lists.
 899     (if (pair? l)
 900         (begin
 901           (if (eqv? (car l) old)
 902               (set-car! l new))
 903           (loop (cdr l))))))
 904
 905 ;;;
 906 ;;; update-direct-subclass!
 907 ;;;
 908
 909 (define-method update-direct-subclass! ((c <class>)
 910                                         (old <class>)
 911                                         (new <class>))
 912   (class-redefinition c
 913                       (make-class (class-direct-supers c)
 914                                   (class-direct-slots c)
 915                                   #:name (class-name c)
 916                                   #:environment (slot-ref c 'environment)
 917                                   #:metaclass (class-of c))))
 918
 919 ;;;
 920 ;;; {Utilities for INITIALIZE methods}
 921 ;;;
 922
 923 ;;; compute-slot-accessors
 924 ;;;
 925 (define (compute-slot-accessors class slots env)
 926   (for-each
 927       (lambda (s g-n-s)
 928         (let ((name            (slot-definition-name     s))
 929               (getter-function (slot-definition-getter   s))
 930               (setter-function (slot-definition-setter   s))
 931               (accessor        (slot-definition-accessor s)))
 932           (if getter-function
 933               (add-method! getter-function
 934                            (compute-getter-method class g-n-s)))
 935           (if setter-function
 936               (add-method! setter-function
 937                            (compute-setter-method class g-n-s)))
 938           (if accessor
 939               (begin
 940                 (add-method! accessor
 941                              (compute-getter-method class g-n-s))
 942                 (add-method! (setter accessor)
 943                              (compute-setter-method class g-n-s))))))
 944       slots (slot-ref class 'getters-n-setters)))
 945
 946 (define-method compute-getter-method ((class <class>) slotdef)
 947   (let ((init-thunk (cadr slotdef))
 948         (g-n-s (cddr slotdef)))
 949     (make <accessor-method>
 950           #:specializers (list class)
 951           #:procedure (cond ((pair? g-n-s)
 952                              (if init-thunk
 953                                  (car g-n-s)
 954                                  (make-generic-bound-check-getter (car g-n-s))
 955                                  ))
 956                             (init-thunk
 957                              (standard-get g-n-s))
 958                             (else
 959                              (bound-check-get g-n-s)))
 960           #:slot-definition slotdef)))
 961
 962 (define-method compute-setter-method ((class <class>) slotdef)
 963   (let ((g-n-s (cddr slotdef)))
 964     (make <accessor-method>
 965           #:specializers (list class <top>)
 966           #:procedure (if (pair? g-n-s)
 967                           (cadr g-n-s)
 968                           (standard-set g-n-s))
 969           #:slot-definition slotdef)))
 970
 971 (define (make-generic-bound-check-getter proc)
 972   (let ((source (and (closure? proc) (procedure-source proc))))
 973     (if (and source (null? (cdddr source)))
 974         (let ((obj (caadr source)))
 975           ;; smart closure compilation
 976           (local-eval
 977            `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
 978            (procedure-environment proc)))
 979         (lambda (o) (assert-bound (proc o) o)))))
 980
 981 (define n-standard-accessor-methods 10)
 982
 983 (define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
 984 (define standard-get-methods (make-vector n-standard-accessor-methods #f))
 985 (define standard-set-methods (make-vector n-standard-accessor-methods #f))
 986
 987 (define (standard-accessor-method make methods)
 988   (lambda (index)
 989     (cond ((>= index n-standard-accessor-methods) (make index))
 990           ((vector-ref methods index))
 991           (else (let ((m (make index)))
 992                   (vector-set! methods index m)
 993                   m)))))
 994
 995 (define (make-bound-check-get index)
 996   (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
 997
 998 (define (make-get index)
 999   (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
1000
1001 (define (make-set index)
1002   (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
1003
1004 (define bound-check-get
1005   (standard-accessor-method make-bound-check-get bound-check-get-methods))
1006 (define standard-get (standard-accessor-method make-get standard-get-methods))
1007 (define standard-set (standard-accessor-method make-set standard-set-methods))
1008
1009 ;;; compute-getters-n-setters
1010 ;;;
1011 (define (compute-getters-n-setters class slots env)
1012
1013   (define (compute-slot-init-function s)
1014     (or (slot-definition-init-thunk s)
1015         (let ((init (slot-definition-init-value s)))
1016           (and (not (unbound? init))
1017                (lambda () init)))))
1018
1019   (define (verify-accessors slot l)
1020     (if (pair? l)
1021         (let ((get (car l))
1022               (set (cadr l)))
1023           (if (not (and (closure? get)
1024                         (= (car (procedure-property get 'arity)) 1)))
1025               (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1026                            slot class get))
1027           (if (not (and (closure? set)
1028                         (= (car (procedure-property set 'arity)) 2)))
1029             (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1030                          slot class set)))))
1031
1032   (map (lambda (s)
1033          (let* ((g-n-s (compute-get-n-set class s))
1034                 (name  (slot-definition-name s)))
1035            ; For each slot we have '(name init-function getter setter)
1036            ; If slot, we have the simplest form '(name init-function . index)
1037            (verify-accessors name g-n-s)
1038            (cons name
1039                  (cons (compute-slot-init-function s)
1040                        g-n-s))))
1041        slots))
1042
1043 ;;; compute-cpl
1044 ;;;
1045 ;;; Correct behaviour:
1046 ;;;
1047 ;;; (define-class food ())
1048 ;;; (define-class fruit (food))
1049 ;;; (define-class spice (food))
1050 ;;; (define-class apple (fruit))
1051 ;;; (define-class cinnamon (spice))
1052 ;;; (define-class pie (apple cinnamon))
1053 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1054 ;;;
1055 ;;; (define-class d ())
1056 ;;; (define-class e ())
1057 ;;; (define-class f ())
1058 ;;; (define-class b (d e))
1059 ;;; (define-class c (e f))
1060 ;;; (define-class a (b c))
1061 ;;; => cpl (a) = a b d c e f object top
1062 ;;;
1063
1064 (define-method compute-cpl ((class <class>))
1065   (compute-std-cpl class class-direct-supers))
1066
1067 ;; Support
1068
1069 (define (only-non-null lst)
1070   (filter (lambda (l) (not (null? l))) lst))
1071
1072 (define (compute-std-cpl c get-direct-supers)
1073   (let ((c-direct-supers (get-direct-supers c)))
1074     (merge-lists (list c)
1075                  (only-non-null (append (map class-precedence-list
1076                                              c-direct-supers)
1077                                         (list c-direct-supers))))))
1078
1079 (define (merge-lists reversed-partial-result inputs)
1080   (cond
1081    ((every null? inputs)
1082     (reverse! reversed-partial-result))
1083    (else
1084     (let* ((candidate (lambda (c)
1085                         (and (not (any (lambda (l)
1086                                          (memq c (cdr l)))
1087                                        inputs))
1088                              c)))
1089            (candidate-car (lambda (l)
1090                             (and (not (null? l))
1091                                  (candidate (car l)))))
1092            (next (any candidate-car inputs)))
1093       (if (not next)
1094           (goops-error "merge-lists: Inconsistent precedence graph"))
1095       (let ((remove-next (lambda (l)
1096                            (if (eq? (car l) next)
1097                                (cdr l)
1098                              l))))
1099         (merge-lists (cons next reversed-partial-result)
1100                      (only-non-null (map remove-next inputs))))))))
1101
1102 ;; Modified from TinyClos:
1103 ;;
1104 ;; A simple topological sort.
1105 ;;
1106 ;; It's in this file so that both TinyClos and Objects can use it.
1107 ;;
1108 ;; This is a fairly modified version of code I originally got from Anurag
1109 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1110 ;;
1111
1112 (define (compute-clos-cpl c get-direct-supers)
1113   (top-sort ((build-transitive-closure get-direct-supers) c)
1114             ((build-constraints get-direct-supers) c)
1115             (std-tie-breaker get-direct-supers)))
1116
1117
1118 (define (top-sort elements constraints tie-breaker)
1119   (let loop ((elements    elements)
1120              (constraints constraints)
1121              (result      '()))
1122     (if (null? elements)
1123         result
1124         (let ((can-go-in-now
1125                (filter
1126                 (lambda (x)
1127                   (every (lambda (constraint)
1128                            (or (not (eq? (cadr constraint) x))
1129                                (memq (car constraint) result)))
1130                          constraints))
1131                 elements)))
1132           (if (null? can-go-in-now)
1133               (goops-error "top-sort: Invalid constraints")
1134               (let ((choice (if (null? (cdr can-go-in-now))
1135                                 (car can-go-in-now)
1136                                 (tie-breaker result
1137                                              can-go-in-now))))
1138                 (loop
1139                  (filter (lambda (x) (not (eq? x choice)))
1140                              elements)
1141                  constraints
1142                  (append result (list choice)))))))))
1143
1144 (define (std-tie-breaker get-supers)
1145   (lambda (partial-cpl min-elts)
1146     (let loop ((pcpl (reverse partial-cpl)))
1147       (let ((current-elt (car pcpl)))
1148         (let ((ds-of-ce (get-supers current-elt)))
1149           (let ((common (filter (lambda (x)
1150                                       (memq x ds-of-ce))
1151                                     min-elts)))
1152             (if (null? common)
1153                 (if (null? (cdr pcpl))
1154                     (goops-error "std-tie-breaker: Nothing valid")
1155                     (loop (cdr pcpl)))
1156                 (car common))))))))
1157
1158
1159 (define (build-transitive-closure get-follow-ons)
1160   (lambda (x)
1161     (let track ((result '())
1162                 (pending (list x)))
1163       (if (null? pending)
1164           result
1165           (let ((next (car pending)))
1166             (if (memq next result)
1167                 (track result (cdr pending))
1168                 (track (cons next result)
1169                        (append (get-follow-ons next)
1170                                (cdr pending)))))))))
1171
1172 (define (build-constraints get-follow-ons)
1173   (lambda (x)
1174     (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1175                (this-one '())
1176                (result '()))
1177       (if (or (null? this-one) (null? (cdr this-one)))
1178           (if (null? elements)
1179               result
1180               (loop (cdr elements)
1181                     (cons (car elements)
1182                           (get-follow-ons (car elements)))
1183                     result))
1184           (loop elements
1185                 (cdr this-one)
1186                 (cons (list (car this-one) (cadr this-one))
1187                       result))))))
1188
1189 ;;; compute-get-n-set
1190 ;;;
1191 (define-method compute-get-n-set ((class <class>) s)
1192   (case (slot-definition-allocation s)
1193     ((#:instance) ;; Instance slot
1194      ;; get-n-set is just its offset
1195      (let ((already-allocated (slot-ref class 'nfields)))
1196        (slot-set! class 'nfields (+ already-allocated 1))
1197        already-allocated))
1198
1199     ((#:class)  ;; Class slot
1200      ;; Class-slots accessors are implemented as 2 closures around
1201      ;; a Scheme variable. As instance slots, class slots must be
1202      ;; unbound at init time.
1203      (let ((name (slot-definition-name s)))
1204        (if (memq name (map slot-definition-name (class-direct-slots class)))
1205            ;; This slot is direct; create a new shared variable
1206            (make-closure-variable class)
1207            ;; Slot is inherited. Find its definition in superclass
1208            (let loop ((l (cdr (class-precedence-list class))))
1209              (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1210                (if r
1211                    (cddr r)
1212                    (loop (cdr l))))))))
1213
1214     ((#:each-subclass) ;; slot shared by instances of direct subclass.
1215      ;; (Thomas Buerger, April 1998)
1216      (make-closure-variable class))
1217
1218     ((#:virtual) ;; No allocation
1219      ;; slot-ref and slot-set! function must be given by the user
1220      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
1221            (set (get-keyword #:slot-set! (slot-definition-options s) #f))
1222            (env (class-environment class)))
1223        (if (not (and get set))
1224            (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
1225                         s))
1226        (list get set)))
1227     (else    (next-method))))
1228
1229 (define (make-closure-variable class)
1230   (let ((shared-variable (make-unbound)))
1231     (list (lambda (o) shared-variable)
1232           (lambda (o v) (set! shared-variable v)))))
1233
1234 (define-method compute-get-n-set ((o <object>) s)
1235   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1236
1237 (define-method compute-slots ((class <class>))
1238   (%compute-slots class))
1239
1240 ;;;
1241 ;;; {Initialize}
1242 ;;;
1243
1244 (define-method initialize ((object <object>) initargs)
1245   (%initialize-object object initargs))
1246
1247 (define-method initialize ((class <class>) initargs)
1248   (next-method)
1249   (let ((dslots (get-keyword #:slots initargs '()))
1250         (supers (get-keyword #:dsupers    initargs '()))
1251         (env    (get-keyword #:environment initargs (top-level-env))))
1252
1253     (slot-set! class 'name              (get-keyword #:name initargs '???))
1254     (slot-set! class 'direct-supers     supers)
1255     (slot-set! class 'direct-slots      dslots)
1256     (slot-set! class 'direct-subclasses '())
1257     (slot-set! class 'direct-methods    '())
1258     (slot-set! class 'cpl               (compute-cpl class))
1259     (slot-set! class 'redefined         #f)
1260     (slot-set! class 'environment       env)
1261     (let ((slots (compute-slots class)))
1262       (slot-set! class 'slots             slots)
1263       (slot-set! class 'nfields           0)
1264       (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1265                                                                      slots
1266                                                                      env))
1267       ;; Build getters - setters - accessors
1268       (compute-slot-accessors class slots env))
1269
1270     ;; Update the "direct-subclasses" of each inherited classes
1271     (for-each (lambda (x)
1272                 (slot-set! x
1273                            'direct-subclasses
1274                            (cons class (slot-ref x 'direct-subclasses))))
1275               supers)
1276
1277     ;; Support for the underlying structs:
1278
1279     ;; Inherit class flags (invisible on scheme level) from supers
1280     (%inherit-magic! class supers)
1281
1282     ;; Set the layout slot
1283     (%prep-layout! class)))
1284
1285 (define object-procedure-tags
1286   '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2))
1287
1288 (define (initialize-object-procedure object initargs)
1289   (let ((proc (get-keyword #:procedure initargs #f)))
1290     (cond ((not proc))
1291           ((pair? proc)
1292            (apply set-object-procedure! object proc))
1293           ((memq (tag proc) object-procedure-tags)
1294            (set-object-procedure! object proc))
1295           (else
1296            (set-object-procedure! object
1297                                   (lambda args (apply proc args)))))))
1298
1299 (define-method initialize ((class <operator-class>) initargs)
1300   (next-method)
1301   (initialize-object-procedure class initargs))
1302
1303 (define-method initialize ((owsc <operator-with-setter-class>) initargs)
1304   (next-method)
1305   (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1306
1307 (define-method initialize ((entity <entity>) initargs)
1308   (next-method)
1309   (initialize-object-procedure entity initargs))
1310
1311 (define-method initialize ((ews <entity-with-setter>) initargs)
1312   (next-method)
1313   (%set-object-setter! ews (get-keyword #:setter initargs #f)))
1314
1315 (define-method initialize ((generic <generic>) initargs)
1316   (let ((previous-definition (get-keyword #:default initargs #f))
1317         (name (get-keyword #:name initargs #f)))
1318     (next-method)
1319     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1320                                     (list (make <method>
1321                                                 #:specializers <top>
1322                                                 #:procedure
1323                                                 (lambda l
1324                                                   (apply previous-definition
1325                                                          l))))
1326                                     '()))
1327     (if name
1328         (set-procedure-property! generic 'name name))
1329     ))
1330
1331 (define-method initialize ((method <method>) initargs)
1332   (next-method)
1333   (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1334   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1335   (slot-set! method 'procedure (get-keyword #:procedure initargs (lambda l '())))
1336   (slot-set! method 'code-table '()))
1337
1338 (define-method initialize ((obj <foreign-object>) initargs))
1339
1340 ;;;
1341 ;;; {Change-class}
1342 ;;;
1343
1344 (define (change-object-class old-instance old-class new-class)
1345   (let ((new-instance (allocate-instance new-class ())))
1346     ;; Initalize the slot of the new instance
1347     (for-each (lambda (slot)
1348                 (if (and (slot-exists-using-class? old-class old-instance slot)
1349                          (eq? (slot-definition-allocation
1350                                (class-slot-definition old-class slot))
1351                               #:instance)
1352                          (slot-bound-using-class? old-class old-instance slot))
1353                     ;; Slot was present and allocated in old instance; copy it
1354                     (slot-set-using-class!
1355                      new-class
1356                      new-instance
1357                      slot
1358                      (slot-ref-using-class old-class old-instance slot))
1359                     ;; slot was absent; initialize it with its default value
1360                     (let ((init (slot-init-function new-class slot)))
1361                       (if init
1362                           (slot-set-using-class!
1363                                new-class
1364                                new-instance
1365                                slot
1366                                (apply init '()))))))
1367               (map slot-definition-name (class-slots new-class)))
1368     ;; Exchange old and new instance in place to keep pointers valid
1369     (%modify-instance old-instance new-instance)
1370     ;; Allow class specific updates of instances (which now are swapped)
1371     (update-instance-for-different-class new-instance old-instance)
1372     old-instance))
1373
1374
1375 (define-method update-instance-for-different-class ((old-instance <object>)
1376                                                     (new-instance
1377                                                      <object>))
1378   ;;not really important what we do, we just need a default method
1379   new-instance)
1380
1381 (define-method change-class ((old-instance <object>) (new-class <class>))
1382   (change-object-class old-instance (class-of old-instance) new-class))
1383
1384 ;;;
1385 ;;; {make}
1386 ;;;
1387 ;;; A new definition which overwrites the previous one which was built-in
1388 ;;;
1389
1390 (define-method allocate-instance ((class <class>) initargs)
1391   (%allocate-instance class initargs))
1392
1393 (define-method make-instance ((class <class>) . initargs)
1394   (let ((instance (allocate-instance class initargs)))
1395     (initialize instance initargs)
1396     instance))
1397
1398 (define make make-instance)
1399
1400 ;;;
1401 ;;; {apply-generic}
1402 ;;;
1403 ;;; Protocol for calling standard generic functions.  This protocol is
1404 ;;; not used for real <generic> functions (in this case we use a
1405 ;;; completely C hard-coded protocol).  Apply-generic is used by
1406 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1407 ;;; The code below is similar to the first MOP described in AMOP. In
1408 ;;; particular, it doesn't used the currified approach to gf
1409 ;;; call. There are 2 reasons for that:
1410 ;;;   - the protocol below is exposed to mimic completely the one written in C
1411 ;;;   - the currified protocol would be imho inefficient in C.
1412 ;;;
1413
1414 (define-method apply-generic ((gf <generic>) args)
1415   (if (null? (slot-ref gf 'methods))
1416       (no-method gf args))
1417   (let ((methods (compute-applicable-methods gf args)))
1418     (if methods
1419         (apply-methods gf (sort-applicable-methods gf methods args) args)
1420         (no-applicable-method gf args))))
1421
1422 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1423 ;; *fixme* use let
1424 (define %%compute-applicable-methods
1425   (make <generic> #:name 'compute-applicable-methods))
1426
1427 (define-method %%compute-applicable-methods ((gf <generic>) args)
1428   (%compute-applicable-methods gf args))
1429
1430 (set! compute-applicable-methods %%compute-applicable-methods)
1431
1432 (define-method sort-applicable-methods ((gf <generic>) methods args)
1433   (let ((targs (map class-of args)))
1434     (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1435
1436 (define-method method-more-specific? ((m1 <method>) (m2 <method>) targs)
1437   (%method-more-specific? m1 m2 targs))
1438
1439 (define-method apply-method ((gf <generic>) methods build-next args)
1440   (apply (method-procedure (car methods))
1441          (build-next (cdr methods) args)
1442          args))
1443
1444 (define-method apply-methods ((gf <generic>) (l <list>) args)
1445   (letrec ((next (lambda (procs args)
1446                    (lambda new-args
1447                      (let ((a (if (null? new-args) args new-args)))
1448                        (if (null? procs)
1449                            (no-next-method gf a)
1450                            (apply-method gf procs next a)))))))
1451     (apply-method gf l next args)))
1452
1453 ;; We don't want the following procedure to turn up in backtraces:
1454 (for-each (lambda (proc)
1455             (set-procedure-property! proc 'system-procedure #t))
1456           (list slot-unbound
1457                 slot-missing
1458                 no-next-method
1459                 no-applicable-method
1460                 no-method
1461                 ))
1462
1463 ;;;
1464 ;;; {<composite-metaclass> and <active-metaclass>}
1465 ;;;
1466
1467 ;(autoload "active-slot"    <active-metaclass>)
1468 ;(autoload "composite-slot" <composite-metaclass>)
1469 ;(export <composite-metaclass> <active-metaclass>)
1470
1471 ;;;
1472 ;;; {Tools}
1473 ;;;
1474
1475 ;; list2set
1476 ;;
1477 ;; duplicate the standard list->set function but using eq instead of
1478 ;; eqv which really sucks a lot, uselessly here
1479 ;;
1480 (define (list2set l)
1481   (let loop ((l l)
1482              (res '()))
1483     (cond
1484      ((null? l) res)
1485      ((memq (car l) res) (loop (cdr l) res))
1486      (else (loop (cdr l) (cons (car l) res))))))
1487
1488 (define (class-subclasses c)
1489   (letrec ((allsubs (lambda (c)
1490                       (cons c (mapappend allsubs
1491                                          (class-direct-subclasses c))))))
1492     (list2set (cdr (allsubs c)))))
1493
1494 (define (class-methods c)
1495   (list2set (mapappend class-direct-methods
1496                        (cons c (class-subclasses c)))))
1497
1498 ;;;
1499 ;;; {Final initialization}
1500 ;;;
1501
1502 ;; Tell C code that the main bulk of Goops has been loaded
1503 (%goops-loaded)