oop/goops.scm

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