module/oop/goops.scm

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