module/oop/goops.scm

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