oop/goops.scm

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