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