module/oop/goops.scm

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