oop/goops.scm

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