oop/goops.scm

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