module/oop/goops.scm

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