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