module/oop/goops.scm

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