module/oop/goops.scm

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