oop/goops.scm

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