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 ((head (cadr exp)))
 429         (if (not (pair? head))
 430             (goops-error "bad method head: ~S" head)
 431             (let ((gf (car head)))
 432               (cond ((and (pair? gf)
 433                           (eq? (car gf) 'setter)
 434                           (pair? (cdr gf))
 435                           (symbol? (cadr gf))
 436                           (null? (cddr gf)))
 437                      ;; named setter method
 438                      (let ((name (cadr gf)))
 439                        (cond ((not (symbol? name))
 440                               `(add-method! (setter ,name)
 441                                             (method ,(cdadr exp)
 442                                                     ,@(cddr exp))))
 443                              ((defined? name env)
 444                               `(begin
 445                                  ;; *fixme* Temporary hack for the current
 446                                  ;;         module system
 447                                  (if (not ,name)
 448                                      (define-accessor ,name))
 449                                  (add-method! (setter ,name)
 450                                               (method ,(cdadr exp)
 451                                                       ,@(cddr exp)))))
 452                              (else
 453                               `(begin
 454                                  (define-accessor ,name)
 455                                  (add-method! (setter ,name)
 456                                               (method ,(cdadr exp)
 457                                                       ,@(cddr exp))))))))
 458                     ((not (symbol? gf))
 459                      `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
 460                     ((defined? gf env)
 461                      `(begin
 462                         ;; *fixme* Temporary hack for the current
 463                         ;;         module system
 464                         (if (not ,gf)
 465                             (define-generic ,gf))
 466                         (add-method! ,gf
 467                                      (method ,(cdadr exp)
 468                                              ,@(cddr exp)))))
 469                     (else
 470                      `(begin
 471                         (define-generic ,gf)
 472                         (add-method! ,gf
 473                                      (method ,(cdadr exp)
 474                                              ,@(cddr exp))))))))))))
 475
 476 (define (make-method specializers procedure)
 477   (make <method>
 478         #:specializers specializers
 479         #:procedure procedure))
 480
 481 (define method
 482   (letrec ((specializers
 483             (lambda (ls)
 484               (cond ((null? ls) '('()))
 485                     ((pair? ls) (cons (if (pair? (car ls))
 486                                           (cadar ls)
 487                                           '<top>)
 488                                       (specializers (cdr ls))))
 489                     (else '(<top>)))))
 490            (formals
 491             (lambda (ls)
 492               (if (pair? ls)
 493                   (cons (if (pair? (car ls)) (caar ls) (car ls))
 494                         (formals (cdr ls)))
 495                   ls))))
 496     (procedure->memoizing-macro
 497       (lambda (exp env)
 498         (let ((args (cadr exp))
 499               (body (cddr exp)))
 500           `(make <method>
 501                  #:specializers (cons* ,@(specializers args))
 502                  #:procedure (lambda ,(formals args)
 503                                ,@(if (null? body)
 504                                      (list *unspecified*)
 505                                      body))))))))
 506
 507 ;;;
 508 ;;; {add-method!}
 509 ;;;
 510
 511 (define (add-method-in-classes! m)
 512   ;; Add method in all the classes which appears in its specializers list
 513   (for-each* (lambda (x)
 514                (let ((dm (class-direct-methods x)))
 515                  (if (not (memv m dm))
 516                      (slot-set! x 'direct-methods (cons m dm)))))
 517              (method-specializers m)))
 518
 519 (define (remove-method-in-classes! m)
 520   ;; Remove method in all the classes which appears in its specializers list
 521   (for-each* (lambda (x)
 522                (slot-set! x
 523                           'direct-methods
 524                           (delv! m (class-direct-methods x))))
 525              (method-specializers m)))
 526
 527 (define (compute-new-list-of-methods gf new)
 528   (let ((new-spec (method-specializers new))
 529         (methods  (generic-function-methods gf)))
 530     (let loop ((l methods))
 531       (if (null? l)
 532           (cons new methods)
 533           (if (equal? (method-specializers (car l)) new-spec)
 534               (begin
 535                 ;; This spec. list already exists. Remove old method from dependents
 536                 (remove-method-in-classes! (car l))
 537                 (set-car! l new)
 538                 methods)
 539               (loop (cdr l)))))))
 540
 541 (define (internal-add-method! gf m)
 542   (slot-set! m  'generic-function gf)
 543   (slot-set! gf 'methods (compute-new-list-of-methods gf m))
 544   (let ((specializers (slot-ref m 'specializers)))
 545     (slot-set! gf 'n-specialized
 546                (max (length* specializers)
 547                     (slot-ref gf 'n-specialized))))
 548   (%invalidate-method-cache! gf)
 549   (add-method-in-classes! m)
 550   *unspecified*)
 551
 552 (define-generic add-method!)
 553
 554 (internal-add-method! add-method!
 555                       (make <method>
 556                         #:specializers (list <generic> <method>)
 557                         #:procedure internal-add-method!))
 558
 559 (define-method (add-method! (proc <procedure>) (m <method>))
 560   (if (generic-capability? proc)
 561       (begin
 562         (enable-primitive-generic! proc)
 563         (add-method! proc m))
 564       (next-method)))
 565
 566 (define-method (add-method! (pg <primitive-generic>) (m <method>))
 567   (add-method! (primitive-generic-generic pg) m))
 568
 569 (define-method (add-method! obj (m <method>))
 570   (goops-error "~S is not a valid generic function" obj))
 571
 572 ;;;
 573 ;;; {Access to meta objects}
 574 ;;;
 575
 576 ;;;
 577 ;;; Methods
 578 ;;;
 579 (define-method (method-source (m <method>))
 580   (let* ((spec (map* class-name (slot-ref m 'specializers)))
 581          (proc (procedure-source (slot-ref m 'procedure)))
 582          (args (cadr proc))
 583          (body (cddr proc)))
 584     (cons 'method
 585           (cons (map* list args spec)
 586                 body))))
 587
 588 ;;;
 589 ;;; Slots
 590 ;;;
 591 (define slot-definition-name car)
 592
 593 (define slot-definition-options cdr)
 594
 595 (define (slot-definition-allocation s)
 596   (get-keyword #:allocation (cdr s) #:instance))
 597
 598 (define (slot-definition-getter s)
 599   (get-keyword #:getter (cdr s) #f))
 600
 601 (define (slot-definition-setter s)
 602   (get-keyword #:setter (cdr s) #f))
 603
 604 (define (slot-definition-accessor s)
 605   (get-keyword #:accessor (cdr s) #f))
 606
 607 (define (slot-definition-init-value s)
 608   ;; can be #f, so we can't use #f as non-value
 609   (get-keyword #:init-value (cdr s) (make-unbound)))
 610
 611 (define (slot-definition-init-form s)
 612   (get-keyword #:init-form (cdr s) (make-unbound)))
 613
 614 (define (slot-definition-init-thunk s)
 615   (get-keyword #:init-thunk (cdr s) #f))
 616
 617 (define (slot-definition-init-keyword s)
 618   (get-keyword #:init-keyword (cdr s) #f))
 619
 620 (define (class-slot-definition class slot-name)
 621   (assq slot-name (class-slots class)))
 622
 623 (define (slot-init-function class slot-name)
 624   (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
 625
 626
 627 ;;;
 628 ;;; {Standard methods used by the C runtime}
 629 ;;;
 630
 631 ;;; Methods to compare objects
 632 ;;;
 633
 634 (define-method (object-eqv? x y)    #f)
 635 (define-method (object-equal? x y)  (eqv? x y))
 636
 637 ;;;
 638 ;;; methods to display/write an object
 639 ;;;
 640
 641 ;     Code for writing objects must test that the slots they use are
 642 ;     bound. Otherwise a slot-unbound method will be called and will
 643 ;     conduct to an infinite loop.
 644
 645 ;; Write
 646 (define (display-address o file)
 647   (display (number->string (object-address o) 16) file))
 648
 649 (define-method (write o file)
 650   (display "#<instance " file)
 651   (display-address o file)
 652   (display #\> file))
 653
 654 (define write-object (primitive-generic-generic write))
 655
 656 (define-method (write (o <object>) file)
 657   (let ((class (class-of o)))
 658     (if (slot-bound? class 'name)
 659         (begin
 660           (display "#<" file)
 661           (display (class-name class) file)
 662           (display #\space file)
 663           (display-address o file)
 664           (display #\> file))
 665         (next-method))))
 666
 667 (define-method (write (o <foreign-object>) file)
 668   (let ((class (class-of o)))
 669     (if (slot-bound? class 'name)
 670         (begin
 671           (display "#<foreign-object " file)
 672           (display (class-name class) file)
 673           (display #\space file)
 674           (display-address o file)
 675           (display #\> file))
 676         (next-method))))
 677
 678 (define-method (write (class <class>) file)
 679   (let ((meta (class-of class)))
 680     (if (and (slot-bound? class 'name)
 681              (slot-bound? meta 'name))
 682         (begin
 683           (display "#<" file)
 684           (display (class-name meta) file)
 685           (display #\space file)
 686           (display (class-name class) file)
 687           (display #\space file)
 688           (display-address class file)
 689           (display #\> file))
 690         (next-method))))
 691
 692 (define-method (write (gf <generic>) file)
 693   (let ((meta (class-of gf)))
 694     (if (and (slot-bound? meta 'name)
 695              (slot-bound? gf 'methods))
 696         (begin
 697           (display "#<" file)
 698           (display (class-name meta) file)
 699           (let ((name (generic-function-name gf)))
 700             (if name
 701                 (begin
 702                   (display #\space file)
 703                   (display name file))))
 704           (display " (" file)
 705           (display (length (generic-function-methods gf)) file)
 706           (display ")>" file))
 707         (next-method))))
 708
 709 (define-method (write (o <method>) file)
 710   (let ((meta (class-of o)))
 711     (if (and (slot-bound? meta 'name)
 712              (slot-bound? o 'specializers))
 713         (begin
 714           (display "#<" file)
 715           (display (class-name meta) file)
 716           (display #\space file)
 717           (display (map* (lambda (spec)
 718                            (if (slot-bound? spec 'name)
 719                                (slot-ref spec 'name)
 720                                spec))
 721                          (method-specializers o))
 722                    file)
 723           (display #\space file)
 724           (display-address o file)
 725           (display #\> file))
 726         (next-method))))
 727
 728 ;; Display (do the same thing as write by default)
 729 (define-method (display o file)
 730   (write-object o file))
 731
 732 ;;;
 733 ;;; slot access
 734 ;;;
 735
 736 (define (class-slot-g-n-s class slot-name)
 737   (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
 738          (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
 739                           (slot-missing class slot-name)))))
 740     (if (not (memq (slot-definition-allocation this-slot)
 741                    '(#:class #:each-subclass)))
 742         (slot-missing class slot-name))
 743     g-n-s))
 744
 745 (define (class-slot-ref class slot)
 746   (let ((x ((car (class-slot-g-n-s class slot)) #f)))
 747     (if (unbound? x)
 748         (slot-unbound class slot)
 749         x)))
 750
 751 (define (class-slot-set! class slot value)
 752   ((cadr (class-slot-g-n-s class slot)) #f value))
 753
 754 (define-method (slot-unbound (c <class>) (o <object>) s)
 755   (goops-error "Slot `~S' is unbound in object ~S" s o))
 756
 757 (define-method (slot-unbound (c <class>) s)
 758   (goops-error "Slot `~S' is unbound in class ~S" s c))
 759
 760 (define-method (slot-unbound (o <object>))
 761   (goops-error "Unbound slot in object ~S" o))
 762
 763 (define-method (slot-missing (c <class>) (o <object>) s)
 764   (goops-error "No slot with name `~S' in object ~S" s o))
 765
 766 (define-method (slot-missing (c <class>) s)
 767   (goops-error "No class slot with name `~S' in class ~S" s c))
 768
 769
 770 (define-method (slot-missing (c <class>) (o <object>) s value)
 771   (slot-missing c o s))
 772
 773 ;;; Methods for the possible error we can encounter when calling a gf
 774
 775 (define-method (no-next-method (gf <generic>) args)
 776   (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
 777
 778 (define-method (no-applicable-method (gf <generic>) args)
 779   (goops-error "No applicable method for ~S in call ~S"
 780                gf (cons (generic-function-name gf) args)))
 781
 782 (define-method (no-method (gf <generic>) args)
 783   (goops-error "No method defined for ~S"  gf))
 784
 785 ;;;
 786 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
 787 ;;;
 788
 789 (define-method (shallow-clone (self <object>))
 790   (let ((clone (%allocate-instance (class-of self) '()))
 791         (slots (map slot-definition-name
 792                     (class-slots (class-of self)))))
 793     (for-each (lambda (slot)
 794                 (if (slot-bound? self slot)
 795                     (slot-set! clone slot (slot-ref self slot))))
 796               slots)
 797     clone))
 798
 799 (define-method (deep-clone  (self <object>))
 800   (let ((clone (%allocate-instance (class-of self) '()))
 801         (slots (map slot-definition-name
 802                     (class-slots (class-of self)))))
 803     (for-each (lambda (slot)
 804                 (if (slot-bound? self slot)
 805                     (slot-set! clone slot
 806                                (let ((value (slot-ref self slot)))
 807                                  (if (instance? value)
 808                                      (deep-clone value)
 809                                      value)))))
 810               slots)
 811     clone))
 812
 813 ;;;
 814 ;;; {Class redefinition utilities}
 815 ;;;
 816
 817 ;;; (class-redefinition OLD NEW)
 818 ;;;
 819
 820 ;;; Has correct the following conditions:
 821
 822 ;;; Methods
 823 ;;;
 824 ;;; 1. New accessor specializers refer to new header
 825 ;;;
 826 ;;; Classes
 827 ;;;
 828 ;;; 1. New class cpl refers to the new class header
 829 ;;; 2. Old class header exists on old super classes direct-subclass lists
 830 ;;; 3. New class header exists on new super classes direct-subclass lists
 831
 832 (define-method (class-redefinition (old <class>) (new <class>))
 833   ;; Work on direct methods:
 834   ;;            1. Remove accessor methods from the old class
 835   ;;            2. Patch the occurences of new in the specializers by old
 836   ;;            3. Displace the methods from old to new
 837   (remove-class-accessors! old)                                 ;; -1-
 838   (let ((methods (class-direct-methods new)))
 839     (for-each (lambda (m)
 840                  (update-direct-method! m new old))     ;; -2-
 841               methods)
 842     (slot-set! new
 843                'direct-methods
 844                (append methods (class-direct-methods old))))
 845
 846   ;; Substitute old for new in new cpl
 847   (set-car! (slot-ref new 'cpl) old)
 848
 849   ;; Remove the old class from the direct-subclasses list of its super classes
 850   (for-each (lambda (c) (slot-set! c 'direct-subclasses
 851                                    (delv! old (class-direct-subclasses c))))
 852             (class-direct-supers old))
 853
 854   ;; Replace the new class with the old in the direct-subclasses of the supers
 855   (for-each (lambda (c)
 856               (slot-set! c 'direct-subclasses
 857                          (cons old (delv! new (class-direct-subclasses c)))))
 858             (class-direct-supers new))
 859
 860   ;; Swap object headers
 861   (%modify-class old new)
 862
 863   ;; Now old is NEW!
 864
 865   ;; Redefine all the subclasses of old to take into account modification
 866   (for-each
 867        (lambda (c)
 868          (update-direct-subclass! c new old))
 869        (class-direct-subclasses new))
 870
 871   ;; Invalidate class so that subsequent instances slot accesses invoke
 872   ;; change-object-class
 873   (slot-set! new 'redefined old)
 874   (%invalidate-class new) ;must come after slot-set!
 875
 876   old)
 877
 878 ;;;
 879 ;;; remove-class-accessors!
 880 ;;;
 881
 882 (define-method (remove-class-accessors! (c <class>))
 883   (for-each (lambda (m)
 884               (if (is-a? m <accessor-method>)
 885                   (remove-method-in-classes! m)))
 886             (class-direct-methods c)))
 887
 888 ;;;
 889 ;;; update-direct-method!
 890 ;;;
 891
 892 (define-method (update-direct-method! (m  <method>)
 893                                       (old <class>)
 894                                       (new <class>))
 895   (let loop ((l (method-specializers m)))
 896     ;; Note: the <top> in dotted list is never used.
 897     ;; So we can work as if we had only proper lists.
 898     (if (pair? l)
 899         (begin
 900           (if (eqv? (car l) old)
 901               (set-car! l new))
 902           (loop (cdr l))))))
 903
 904 ;;;
 905 ;;; update-direct-subclass!
 906 ;;;
 907
 908 (define-method (update-direct-subclass! (c <class>)
 909                                         (old <class>)
 910                                         (new <class>))
 911   (class-redefinition c
 912                       (make-class (class-direct-supers c)
 913                                   (class-direct-slots c)
 914                                   #:name (class-name c)
 915                                   #:environment (slot-ref c 'environment)
 916                                   #:metaclass (class-of c))))
 917
 918 ;;;
 919 ;;; {Utilities for INITIALIZE methods}
 920 ;;;
 921
 922 ;;; compute-slot-accessors
 923 ;;;
 924 (define (compute-slot-accessors class slots env)
 925   (for-each
 926       (lambda (s g-n-s)
 927         (let ((name            (slot-definition-name     s))
 928               (getter-function (slot-definition-getter   s))
 929               (setter-function (slot-definition-setter   s))
 930               (accessor        (slot-definition-accessor s)))
 931           (if getter-function
 932               (add-method! getter-function
 933                            (compute-getter-method class g-n-s)))
 934           (if setter-function
 935               (add-method! setter-function
 936                            (compute-setter-method class g-n-s)))
 937           (if accessor
 938               (begin
 939                 (add-method! accessor
 940                              (compute-getter-method class g-n-s))
 941                 (add-method! (setter accessor)
 942                              (compute-setter-method class g-n-s))))))
 943       slots (slot-ref class 'getters-n-setters)))
 944
 945 (define-method (compute-getter-method (class <class>) slotdef)
 946   (let ((init-thunk (cadr slotdef))
 947         (g-n-s (cddr slotdef)))
 948     (make <accessor-method>
 949           #:specializers (list class)
 950           #:procedure (cond ((pair? g-n-s)
 951                              (if init-thunk
 952                                  (car g-n-s)
 953                                  (make-generic-bound-check-getter (car g-n-s))
 954                                  ))
 955                             (init-thunk
 956                              (standard-get g-n-s))
 957                             (else
 958                              (bound-check-get g-n-s)))
 959           #:slot-definition slotdef)))
 960
 961 (define-method (compute-setter-method (class <class>) slotdef)
 962   (let ((g-n-s (cddr slotdef)))
 963     (make <accessor-method>
 964           #:specializers (list class <top>)
 965           #:procedure (if (pair? g-n-s)
 966                           (cadr g-n-s)
 967                           (standard-set g-n-s))
 968           #:slot-definition slotdef)))
 969
 970 (define (make-generic-bound-check-getter proc)
 971   (let ((source (and (closure? proc) (procedure-source proc))))
 972     (if (and source (null? (cdddr source)))
 973         (let ((obj (caadr source)))
 974           ;; smart closure compilation
 975           (local-eval
 976            `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
 977            (procedure-environment proc)))
 978         (lambda (o) (assert-bound (proc o) o)))))
 979
 980 (define n-standard-accessor-methods 10)
 981
 982 (define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
 983 (define standard-get-methods (make-vector n-standard-accessor-methods #f))
 984 (define standard-set-methods (make-vector n-standard-accessor-methods #f))
 985
 986 (define (standard-accessor-method make methods)
 987   (lambda (index)
 988     (cond ((>= index n-standard-accessor-methods) (make index))
 989           ((vector-ref methods index))
 990           (else (let ((m (make index)))
 991                   (vector-set! methods index m)
 992                   m)))))
 993
 994 (define (make-bound-check-get index)
 995   (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
 996
 997 (define (make-get index)
 998   (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
 999
1000 (define (make-set index)
1001   (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
1002
1003 (define bound-check-get
1004   (standard-accessor-method make-bound-check-get bound-check-get-methods))
1005 (define standard-get (standard-accessor-method make-get standard-get-methods))
1006 (define standard-set (standard-accessor-method make-set standard-set-methods))
1007
1008 ;;; compute-getters-n-setters
1009 ;;;
1010 (define (compute-getters-n-setters class slots env)
1011
1012   (define (compute-slot-init-function s)
1013     (or (slot-definition-init-thunk s)
1014         (let ((init (slot-definition-init-value s)))
1015           (and (not (unbound? init))
1016                (lambda () init)))))
1017
1018   (define (verify-accessors slot l)
1019     (if (pair? l)
1020         (let ((get (car l))
1021               (set (cadr l)))
1022           (if (not (and (closure? get)
1023                         (= (car (procedure-property get 'arity)) 1)))
1024               (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1025                            slot class get))
1026           (if (not (and (closure? set)
1027                         (= (car (procedure-property set 'arity)) 2)))
1028             (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1029                          slot class set)))))
1030
1031   (map (lambda (s)
1032          (let* ((g-n-s (compute-get-n-set class s))
1033                 (name  (slot-definition-name s)))
1034            ; For each slot we have '(name init-function getter setter)
1035            ; If slot, we have the simplest form '(name init-function . index)
1036            (verify-accessors name g-n-s)
1037            (cons name
1038                  (cons (compute-slot-init-function s)
1039                        g-n-s))))
1040        slots))
1041
1042 ;;; compute-cpl
1043 ;;;
1044 ;;; Correct behaviour:
1045 ;;;
1046 ;;; (define-class food ())
1047 ;;; (define-class fruit (food))
1048 ;;; (define-class spice (food))
1049 ;;; (define-class apple (fruit))
1050 ;;; (define-class cinnamon (spice))
1051 ;;; (define-class pie (apple cinnamon))
1052 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1053 ;;;
1054 ;;; (define-class d ())
1055 ;;; (define-class e ())
1056 ;;; (define-class f ())
1057 ;;; (define-class b (d e))
1058 ;;; (define-class c (e f))
1059 ;;; (define-class a (b c))
1060 ;;; => cpl (a) = a b d c e f object top
1061 ;;;
1062
1063 (define-method (compute-cpl (class <class>))
1064   (compute-std-cpl class class-direct-supers))
1065
1066 ;; Support
1067
1068 (define (only-non-null lst)
1069   (filter (lambda (l) (not (null? l))) lst))
1070
1071 (define (compute-std-cpl c get-direct-supers)
1072   (let ((c-direct-supers (get-direct-supers c)))
1073     (merge-lists (list c)
1074                  (only-non-null (append (map class-precedence-list
1075                                              c-direct-supers)
1076                                         (list c-direct-supers))))))
1077
1078 (define (merge-lists reversed-partial-result inputs)
1079   (cond
1080    ((every null? inputs)
1081     (reverse! reversed-partial-result))
1082    (else
1083     (let* ((candidate (lambda (c)
1084                         (and (not (any (lambda (l)
1085                                          (memq c (cdr l)))
1086                                        inputs))
1087                              c)))
1088            (candidate-car (lambda (l)
1089                             (and (not (null? l))
1090                                  (candidate (car l)))))
1091            (next (any candidate-car inputs)))
1092       (if (not next)
1093           (goops-error "merge-lists: Inconsistent precedence graph"))
1094       (let ((remove-next (lambda (l)
1095                            (if (eq? (car l) next)
1096                                (cdr l)
1097                              l))))
1098         (merge-lists (cons next reversed-partial-result)
1099                      (only-non-null (map remove-next inputs))))))))
1100
1101 ;; Modified from TinyClos:
1102 ;;
1103 ;; A simple topological sort.
1104 ;;
1105 ;; It's in this file so that both TinyClos and Objects can use it.
1106 ;;
1107 ;; This is a fairly modified version of code I originally got from Anurag
1108 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1109 ;;
1110
1111 (define (compute-clos-cpl c get-direct-supers)
1112   (top-sort ((build-transitive-closure get-direct-supers) c)
1113             ((build-constraints get-direct-supers) c)
1114             (std-tie-breaker get-direct-supers)))
1115
1116
1117 (define (top-sort elements constraints tie-breaker)
1118   (let loop ((elements    elements)
1119              (constraints constraints)
1120              (result      '()))
1121     (if (null? elements)
1122         result
1123         (let ((can-go-in-now
1124                (filter
1125                 (lambda (x)
1126                   (every (lambda (constraint)
1127                            (or (not (eq? (cadr constraint) x))
1128                                (memq (car constraint) result)))
1129                          constraints))
1130                 elements)))
1131           (if (null? can-go-in-now)
1132               (goops-error "top-sort: Invalid constraints")
1133               (let ((choice (if (null? (cdr can-go-in-now))
1134                                 (car can-go-in-now)
1135                                 (tie-breaker result
1136                                              can-go-in-now))))
1137                 (loop
1138                  (filter (lambda (x) (not (eq? x choice)))
1139                              elements)
1140                  constraints
1141                  (append result (list choice)))))))))
1142
1143 (define (std-tie-breaker get-supers)
1144   (lambda (partial-cpl min-elts)
1145     (let loop ((pcpl (reverse partial-cpl)))
1146       (let ((current-elt (car pcpl)))
1147         (let ((ds-of-ce (get-supers current-elt)))
1148           (let ((common (filter (lambda (x)
1149                                       (memq x ds-of-ce))
1150                                     min-elts)))
1151             (if (null? common)
1152                 (if (null? (cdr pcpl))
1153                     (goops-error "std-tie-breaker: Nothing valid")
1154                     (loop (cdr pcpl)))
1155                 (car common))))))))
1156
1157
1158 (define (build-transitive-closure get-follow-ons)
1159   (lambda (x)
1160     (let track ((result '())
1161                 (pending (list x)))
1162       (if (null? pending)
1163           result
1164           (let ((next (car pending)))
1165             (if (memq next result)
1166                 (track result (cdr pending))
1167                 (track (cons next result)
1168                        (append (get-follow-ons next)
1169                                (cdr pending)))))))))
1170
1171 (define (build-constraints get-follow-ons)
1172   (lambda (x)
1173     (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1174                (this-one '())
1175                (result '()))
1176       (if (or (null? this-one) (null? (cdr this-one)))
1177           (if (null? elements)
1178               result
1179               (loop (cdr elements)
1180                     (cons (car elements)
1181                           (get-follow-ons (car elements)))
1182                     result))
1183           (loop elements
1184                 (cdr this-one)
1185                 (cons (list (car this-one) (cadr this-one))
1186                       result))))))
1187
1188 ;;; compute-get-n-set
1189 ;;;
1190 (define-method (compute-get-n-set (class <class>) s)
1191   (case (slot-definition-allocation s)
1192     ((#:instance) ;; Instance slot
1193      ;; get-n-set is just its offset
1194      (let ((already-allocated (slot-ref class 'nfields)))
1195        (slot-set! class 'nfields (+ already-allocated 1))
1196        already-allocated))
1197
1198     ((#:class)  ;; Class slot
1199      ;; Class-slots accessors are implemented as 2 closures around
1200      ;; a Scheme variable. As instance slots, class slots must be
1201      ;; unbound at init time.
1202      (let ((name (slot-definition-name s)))
1203        (if (memq name (map slot-definition-name (class-direct-slots class)))
1204            ;; This slot is direct; create a new shared variable
1205            (make-closure-variable class)
1206            ;; Slot is inherited. Find its definition in superclass
1207            (let loop ((l (cdr (class-precedence-list class))))
1208              (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1209                (if r
1210                    (cddr r)
1211                    (loop (cdr l))))))))
1212
1213     ((#:each-subclass) ;; slot shared by instances of direct subclass.
1214      ;; (Thomas Buerger, April 1998)
1215      (make-closure-variable class))
1216
1217     ((#:virtual) ;; No allocation
1218      ;; slot-ref and slot-set! function must be given by the user
1219      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
1220            (set (get-keyword #:slot-set! (slot-definition-options s) #f))
1221            (env (class-environment class)))
1222        (if (not (and get set))
1223            (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
1224                         s))
1225        (list get set)))
1226     (else    (next-method))))
1227
1228 (define (make-closure-variable class)
1229   (let ((shared-variable (make-unbound)))
1230     (list (lambda (o) shared-variable)
1231           (lambda (o v) (set! shared-variable v)))))
1232
1233 (define-method (compute-get-n-set (o <object>) s)
1234   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1235
1236 (define-method (compute-slots (class <class>))
1237   (%compute-slots class))
1238
1239 ;;;
1240 ;;; {Initialize}
1241 ;;;
1242
1243 (define-method (initialize (object <object>) initargs)
1244   (%initialize-object object initargs))
1245
1246 (define-method (initialize (class <class>) initargs)
1247   (next-method)
1248   (let ((dslots (get-keyword #:slots initargs '()))
1249         (supers (get-keyword #:dsupers    initargs '()))
1250         (env    (get-keyword #:environment initargs (top-level-env))))
1251
1252     (slot-set! class 'name              (get-keyword #:name initargs '???))
1253     (slot-set! class 'direct-supers     supers)
1254     (slot-set! class 'direct-slots      dslots)
1255     (slot-set! class 'direct-subclasses '())
1256     (slot-set! class 'direct-methods    '())
1257     (slot-set! class 'cpl               (compute-cpl class))
1258     (slot-set! class 'redefined         #f)
1259     (slot-set! class 'environment       env)
1260     (let ((slots (compute-slots class)))
1261       (slot-set! class 'slots             slots)
1262       (slot-set! class 'nfields           0)
1263       (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1264                                                                      slots
1265                                                                      env))
1266       ;; Build getters - setters - accessors
1267       (compute-slot-accessors class slots env))
1268
1269     ;; Update the "direct-subclasses" of each inherited classes
1270     (for-each (lambda (x)
1271                 (slot-set! x
1272                            'direct-subclasses
1273                            (cons class (slot-ref x 'direct-subclasses))))
1274               supers)
1275
1276     ;; Support for the underlying structs:
1277
1278     ;; Inherit class flags (invisible on scheme level) from supers
1279     (%inherit-magic! class supers)
1280
1281     ;; Set the layout slot
1282     (%prep-layout! class)))
1283
1284 (define object-procedure-tags
1285   '(utag_closure utag_subr_1 utag_subr_2 utag_subr3 utag_lsubr_2))
1286
1287 (define (initialize-object-procedure object initargs)
1288   (let ((proc (get-keyword #:procedure initargs #f)))
1289     (cond ((not proc))
1290           ((pair? proc)
1291            (apply set-object-procedure! object proc))
1292           ((memq (tag proc) object-procedure-tags)
1293            (set-object-procedure! object proc))
1294           (else
1295            (set-object-procedure! object
1296                                   (lambda args (apply proc args)))))))
1297
1298 (define-method (initialize (class <operator-class>) initargs)
1299   (next-method)
1300   (initialize-object-procedure class initargs))
1301
1302 (define-method (initialize (owsc <operator-with-setter-class>) initargs)
1303   (next-method)
1304   (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1305
1306 (define-method (initialize (entity <entity>) initargs)
1307   (next-method)
1308   (initialize-object-procedure entity initargs))
1309
1310 (define-method (initialize (ews <entity-with-setter>) initargs)
1311   (next-method)
1312   (%set-object-setter! ews (get-keyword #:setter initargs #f)))
1313
1314 (define-method (initialize (generic <generic>) initargs)
1315   (let ((previous-definition (get-keyword #:default initargs #f))
1316         (name (get-keyword #:name initargs #f)))
1317     (next-method)
1318     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1319                                     (list (make <method>
1320                                                 #:specializers <top>
1321                                                 #:procedure
1322                                                 (lambda l
1323                                                   (apply previous-definition
1324                                                          l))))
1325                                     '()))
1326     (if name
1327         (set-procedure-property! generic 'name name))
1328     ))
1329
1330 (define dummy-procedure (lambda args *unspecified*))
1331
1332 (define-method (initialize (method <method>) initargs)
1333   (next-method)
1334   (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1335   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1336   (slot-set! method 'procedure
1337              (get-keyword #:procedure initargs dummy-procedure))
1338   (slot-set! method 'code-table '()))
1339
1340 (define-method (initialize (obj <foreign-object>) initargs))
1341
1342 ;;;
1343 ;;; {Change-class}
1344 ;;;
1345
1346 (define (change-object-class old-instance old-class new-class)
1347   (let ((new-instance (allocate-instance new-class '())))
1348     ;; Initalize the slot of the new instance
1349     (for-each (lambda (slot)
1350                 (if (and (slot-exists-using-class? old-class old-instance slot)
1351                          (eq? (slot-definition-allocation
1352                                (class-slot-definition old-class slot))
1353                               #:instance)
1354                          (slot-bound-using-class? old-class old-instance slot))
1355                     ;; Slot was present and allocated in old instance; copy it
1356                     (slot-set-using-class!
1357                      new-class
1358                      new-instance
1359                      slot
1360                      (slot-ref-using-class old-class old-instance slot))
1361                     ;; slot was absent; initialize it with its default value
1362                     (let ((init (slot-init-function new-class slot)))
1363                       (if init
1364                           (slot-set-using-class!
1365                                new-class
1366                                new-instance
1367                                slot
1368                                (apply init '()))))))
1369               (map slot-definition-name (class-slots new-class)))
1370     ;; Exchange old and new instance in place to keep pointers valid
1371     (%modify-instance old-instance new-instance)
1372     ;; Allow class specific updates of instances (which now are swapped)
1373     (update-instance-for-different-class new-instance old-instance)
1374     old-instance))
1375
1376
1377 (define-method (update-instance-for-different-class (old-instance <object>)
1378                                                     (new-instance
1379                                                      <object>))
1380   ;;not really important what we do, we just need a default method
1381   new-instance)
1382
1383 (define-method (change-class (old-instance <object>) (new-class <class>))
1384   (change-object-class old-instance (class-of old-instance) new-class))
1385
1386 ;;;
1387 ;;; {make}
1388 ;;;
1389 ;;; A new definition which overwrites the previous one which was built-in
1390 ;;;
1391
1392 (define-method (allocate-instance (class <class>) initargs)
1393   (%allocate-instance class initargs))
1394
1395 (define-method (make-instance (class <class>) . initargs)
1396   (let ((instance (allocate-instance class initargs)))
1397     (initialize instance initargs)
1398     instance))
1399
1400 (define make make-instance)
1401
1402 ;;;
1403 ;;; {apply-generic}
1404 ;;;
1405 ;;; Protocol for calling standard generic functions.  This protocol is
1406 ;;; not used for real <generic> functions (in this case we use a
1407 ;;; completely C hard-coded protocol).  Apply-generic is used by
1408 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1409 ;;; The code below is similar to the first MOP described in AMOP. In
1410 ;;; particular, it doesn't used the currified approach to gf
1411 ;;; call. There are 2 reasons for that:
1412 ;;;   - the protocol below is exposed to mimic completely the one written in C
1413 ;;;   - the currified protocol would be imho inefficient in C.
1414 ;;;
1415
1416 (define-method (apply-generic (gf <generic>) args)
1417   (if (null? (slot-ref gf 'methods))
1418       (no-method gf args))
1419   (let ((methods (compute-applicable-methods gf args)))
1420     (if methods
1421         (apply-methods gf (sort-applicable-methods gf methods args) args)
1422         (no-applicable-method gf args))))
1423
1424 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1425 ;; *fixme* use let
1426 (define %%compute-applicable-methods
1427   (make <generic> #:name 'compute-applicable-methods))
1428
1429 (define-method (%%compute-applicable-methods (gf <generic>) args)
1430   (%compute-applicable-methods gf args))
1431
1432 (set! compute-applicable-methods %%compute-applicable-methods)
1433
1434 (define-method (sort-applicable-methods (gf <generic>) methods args)
1435   (let ((targs (map class-of args)))
1436     (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1437
1438 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1439   (%method-more-specific? m1 m2 targs))
1440
1441 (define-method (apply-method (gf <generic>) methods build-next args)
1442   (apply (method-procedure (car methods))
1443          (build-next (cdr methods) args)
1444          args))
1445
1446 (define-method (apply-methods (gf <generic>) (l <list>) args)
1447   (letrec ((next (lambda (procs args)
1448                    (lambda new-args
1449                      (let ((a (if (null? new-args) args new-args)))
1450                        (if (null? procs)
1451                            (no-next-method gf a)
1452                            (apply-method gf procs next a)))))))
1453     (apply-method gf l next args)))
1454
1455 ;; We don't want the following procedure to turn up in backtraces:
1456 (for-each (lambda (proc)
1457             (set-procedure-property! proc 'system-procedure #t))
1458           (list slot-unbound
1459                 slot-missing
1460                 no-next-method
1461                 no-applicable-method
1462                 no-method
1463                 ))
1464
1465 ;;;
1466 ;;; {<composite-metaclass> and <active-metaclass>}
1467 ;;;
1468
1469 ;(autoload "active-slot"    <active-metaclass>)
1470 ;(autoload "composite-slot" <composite-metaclass>)
1471 ;(export <composite-metaclass> <active-metaclass>)
1472
1473 ;;;
1474 ;;; {Tools}
1475 ;;;
1476
1477 ;; list2set
1478 ;;
1479 ;; duplicate the standard list->set function but using eq instead of
1480 ;; eqv which really sucks a lot, uselessly here
1481 ;;
1482 (define (list2set l)
1483   (let loop ((l l)
1484              (res '()))
1485     (cond
1486      ((null? l) res)
1487      ((memq (car l) res) (loop (cdr l) res))
1488      (else (loop (cdr l) (cons (car l) res))))))
1489
1490 (define (class-subclasses c)
1491   (letrec ((allsubs (lambda (c)
1492                       (cons c (mapappend allsubs
1493                                          (class-direct-subclasses c))))))
1494     (list2set (cdr (allsubs c)))))
1495
1496 (define (class-methods c)
1497   (list2set (mapappend class-direct-methods
1498                        (cons c (class-subclasses c)))))
1499
1500 ;;;
1501 ;;; {Final initialization}
1502 ;;;
1503
1504 ;; Tell C code that the main bulk of Goops has been loaded
1505 (%goops-loaded)