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-syntax method
 481   (lambda (x)
 482     (define (parse-args args)
 483       (let lp ((ls args) (formals '()) (specializers '()))
 484         (syntax-case ls ()
 485           (((f s) . rest)
 486            (and (identifier? (syntax f)) (identifier? (syntax s)))
 487            (lp (syntax rest)
 488                (cons (syntax f) formals)
 489                (cons (syntax s) specializers)))
 490           ((f . rest)
 491            (identifier? (syntax f))
 492            (lp (syntax rest)
 493                (cons (syntax f) formals)
 494                (cons (syntax <top>) specializers)))
 495           (()
 496            (list (reverse formals)
 497                  (reverse (cons (syntax '()) specializers))))
 498           (tail
 499            (identifier? (syntax tail))
 500            (list (append (reverse formals) (syntax tail))
 501                  (reverse (cons (syntax <top>) specializers)))))))
 502
 503     (define (find-free-id exp referent)
 504       (syntax-case exp ()
 505         ((x . y)
 506          (or (find-free-id (syntax x) referent)
 507              (find-free-id (syntax y) referent)))
 508         (x
 509          (identifier? (syntax x))
 510          (let ((id (datum->syntax (syntax x) referent)))
 511            (and (free-identifier=? (syntax x) id) id)))
 512         (_ #f)))
 513
 514     (define (compute-procedure formals body)
 515       (syntax-case body ()
 516         ((body0 ...)
 517          (with-syntax ((formals formals))
 518            (syntax (lambda formals body0 ...))))))
 519
 520     (define (->proper args)
 521       (let lp ((ls args) (out '()))
 522         (syntax-case ls ()
 523           ((x . xs)        (lp (syntax xs) (cons (syntax x) out)))
 524           (()              (reverse out))
 525           (tail            (reverse (cons (syntax tail) out))))))
 526
 527     (define (compute-make-procedure formals body next-method)
 528       (syntax-case body ()
 529         ((body ...)
 530          (with-syntax ((next-method next-method))
 531            (syntax-case formals ()
 532              ((formal ...)
 533               (syntax
 534                (lambda (real-next-method)
 535                  (lambda (formal ...)
 536                    (let ((next-method (lambda args
 537                                         (if (null? args)
 538                                             (real-next-method formal ...)
 539                                             (apply real-next-method args)))))
 540                      body ...)))))
 541              (formals
 542               (with-syntax (((formal ...) (->proper (syntax formals))))
 543                 (syntax
 544                  (lambda (real-next-method)
 545                    (lambda formals
 546                      (let ((next-method (lambda args
 547                                           (if (null? args)
 548                                               (apply real-next-method formal ...)
 549                                               (apply real-next-method args)))))
 550                        body ...)))))))))))
 551
 552     (define (compute-procedures formals body)
 553       ;; So, our use of this is broken, because it operates on the
 554       ;; pre-expansion source code. It's equivalent to just searching
 555       ;; for referent in the datums. Ah well.
 556       (let ((id (find-free-id body 'next-method)))
 557         (if id
 558             ;; return a make-procedure
 559             (values (syntax #f)
 560                     (compute-make-procedure formals body id))
 561             (values (compute-procedure formals body)
 562                     (syntax #f)))))
 563
 564     (syntax-case x ()
 565       ((_ args) (syntax (method args (if #f #f))))
 566       ((_ args body0 body1 ...)
 567        (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
 568          (call-with-values
 569              (lambda ()
 570                (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
 571            (lambda (procedure make-procedure)
 572              (with-syntax ((procedure procedure)
 573                            (make-procedure make-procedure))
 574                (syntax
 575                 (make <method>
 576                   #:specializers (cons* specializer ...)
 577                   #:formals 'formals
 578                   #:body '(body0 body1 ...)
 579                   #:make-procedure make-procedure
 580                   #:procedure procedure))))))))))
 581
 582 ;;;
 583 ;;; {add-method!}
 584 ;;;
 585
 586 (define (add-method-in-classes! m)
 587   ;; Add method in all the classes which appears in its specializers list
 588   (for-each* (lambda (x)
 589                (let ((dm (class-direct-methods x)))
 590                  (if (not (memq m dm))
 591                      (slot-set! x 'direct-methods (cons m dm)))))
 592              (method-specializers m)))
 593
 594 (define (remove-method-in-classes! m)
 595   ;; Remove method in all the classes which appears in its specializers list
 596   (for-each* (lambda (x)
 597                (slot-set! x
 598                           'direct-methods
 599                           (delv! m (class-direct-methods x))))
 600              (method-specializers m)))
 601
 602 (define (compute-new-list-of-methods gf new)
 603   (let ((new-spec (method-specializers new))
 604         (methods  (slot-ref gf 'methods)))
 605     (let loop ((l methods))
 606       (if (null? l)
 607           (cons new methods)
 608           (if (equal? (method-specializers (car l)) new-spec)
 609               (begin
 610                 ;; This spec. list already exists. Remove old method from dependents
 611                 (remove-method-in-classes! (car l))
 612                 (set-car! l new)
 613                 methods)
 614               (loop (cdr l)))))))
 615
 616 (define internal-add-method!
 617   (method ((gf <generic>) (m <method>))
 618     (slot-set! m  'generic-function gf)
 619     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
 620     (let ((specializers (slot-ref m 'specializers)))
 621       (slot-set! gf 'n-specialized
 622                  (max (length* specializers)
 623                       (slot-ref gf 'n-specialized))))
 624     (%invalidate-method-cache! gf)
 625     (add-method-in-classes! m)
 626     *unspecified*))
 627
 628 (define-generic add-method!)
 629
 630 ((method-procedure internal-add-method!) add-method! internal-add-method!)
 631
 632 (define-method (add-method! (proc <procedure>) (m <method>))
 633   (if (generic-capability? proc)
 634       (begin
 635         (enable-primitive-generic! proc)
 636         (add-method! proc m))
 637       (next-method)))
 638
 639 (define-method (add-method! (pg <primitive-generic>) (m <method>))
 640   (add-method! (primitive-generic-generic pg) m))
 641
 642 (define-method (add-method! obj (m <method>))
 643   (goops-error "~S is not a valid generic function" obj))
 644
 645 ;;;
 646 ;;; {Access to meta objects}
 647 ;;;
 648
 649 ;;;
 650 ;;; Methods
 651 ;;;
 652 (define-method (method-source (m <method>))
 653   (let* ((spec (map* class-name (slot-ref m 'specializers)))
 654          (src (procedure-source (slot-ref m 'procedure))))
 655     (and src
 656          (let ((args (cadr src))
 657                (body (cddr src)))
 658            (cons 'method
 659                  (cons (map* list args spec)
 660                        body))))))
 661
 662 (define-method (method-formals (m <method>))
 663   (slot-ref m 'formals))
 664
 665 ;;;
 666 ;;; Slots
 667 ;;;
 668 (define slot-definition-name car)
 669
 670 (define slot-definition-options cdr)
 671
 672 (define (slot-definition-allocation s)
 673   (get-keyword #:allocation (cdr s) #:instance))
 674
 675 (define (slot-definition-getter s)
 676   (get-keyword #:getter (cdr s) #f))
 677
 678 (define (slot-definition-setter s)
 679   (get-keyword #:setter (cdr s) #f))
 680
 681 (define (slot-definition-accessor s)
 682   (get-keyword #:accessor (cdr s) #f))
 683
 684 (define (slot-definition-init-value s)
 685   ;; can be #f, so we can't use #f as non-value
 686   (get-keyword #:init-value (cdr s) (make-unbound)))
 687
 688 (define (slot-definition-init-form s)
 689   (get-keyword #:init-form (cdr s) (make-unbound)))
 690
 691 (define (slot-definition-init-thunk s)
 692   (get-keyword #:init-thunk (cdr s) #f))
 693
 694 (define (slot-definition-init-keyword s)
 695   (get-keyword #:init-keyword (cdr s) #f))
 696
 697 (define (class-slot-definition class slot-name)
 698   (assq slot-name (class-slots class)))
 699
 700 (define (slot-init-function class slot-name)
 701   (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
 702
 703
 704 ;;;
 705 ;;; {Standard methods used by the C runtime}
 706 ;;;
 707
 708 ;;; Methods to compare objects
 709 ;;;
 710
 711 (define-method (eqv? x y) #f)
 712 (define-method (equal? x y) (eqv? x y))
 713
 714 ;;;
 715 ;;; methods to display/write an object
 716 ;;;
 717
 718 ;     Code for writing objects must test that the slots they use are
 719 ;     bound. Otherwise a slot-unbound method will be called and will
 720 ;     conduct to an infinite loop.
 721
 722 ;; Write
 723 (define (display-address o file)
 724   (display (number->string (object-address o) 16) file))
 725
 726 (define-method (write o file)
 727   (display "#<instance " file)
 728   (display-address o file)
 729   (display #\> file))
 730
 731 (define write-object (primitive-generic-generic write))
 732
 733 (define-method (write (o <object>) file)
 734   (let ((class (class-of o)))
 735     (if (slot-bound? class 'name)
 736         (begin
 737           (display "#<" file)
 738           (display (class-name class) file)
 739           (display #\space file)
 740           (display-address o file)
 741           (display #\> file))
 742         (next-method))))
 743
 744 (define-method (write (o <foreign-object>) file)
 745   (let ((class (class-of o)))
 746     (if (slot-bound? class 'name)
 747         (begin
 748           (display "#<foreign-object " file)
 749           (display (class-name class) file)
 750           (display #\space file)
 751           (display-address o file)
 752           (display #\> file))
 753         (next-method))))
 754
 755 (define-method (write (class <class>) file)
 756   (let ((meta (class-of class)))
 757     (if (and (slot-bound? class 'name)
 758              (slot-bound? meta 'name))
 759         (begin
 760           (display "#<" file)
 761           (display (class-name meta) file)
 762           (display #\space file)
 763           (display (class-name class) file)
 764           (display #\space file)
 765           (display-address class file)
 766           (display #\> file))
 767         (next-method))))
 768
 769 (define-method (write (gf <generic>) file)
 770   (let ((meta (class-of gf)))
 771     (if (and (slot-bound? meta 'name)
 772              (slot-bound? gf 'methods))
 773         (begin
 774           (display "#<" file)
 775           (display (class-name meta) file)
 776           (let ((name (generic-function-name gf)))
 777             (if name
 778                 (begin
 779                   (display #\space file)
 780                   (display name file))))
 781           (display " (" file)
 782           (display (length (generic-function-methods gf)) file)
 783           (display ")>" file))
 784         (next-method))))
 785
 786 (define-method (write (o <method>) file)
 787   (let ((meta (class-of o)))
 788     (if (and (slot-bound? meta 'name)
 789              (slot-bound? o 'specializers))
 790         (begin
 791           (display "#<" file)
 792           (display (class-name meta) file)
 793           (display #\space file)
 794           (display (map* (lambda (spec)
 795                            (if (slot-bound? spec 'name)
 796                                (slot-ref spec 'name)
 797                                spec))
 798                          (method-specializers o))
 799                    file)
 800           (display #\space file)
 801           (display-address o file)
 802           (display #\> file))
 803         (next-method))))
 804
 805 ;; Display (do the same thing as write by default)
 806 (define-method (display o file)
 807   (write-object o file))
 808
 809 ;;;
 810 ;;; Handling of duplicate bindings in the module system
 811 ;;;
 812
 813 (define-method (merge-generics (module <module>)
 814                                (name <symbol>)
 815                                (int1 <module>)
 816                                (val1 <top>)
 817                                (int2 <module>)
 818                                (val2 <top>)
 819                                (var <top>)
 820                                (val <top>))
 821   #f)
 822
 823 (define-method (merge-generics (module <module>)
 824                                (name <symbol>)
 825                                (int1 <module>)
 826                                (val1 <generic>)
 827                                (int2 <module>)
 828                                (val2 <generic>)
 829                                (var <top>)
 830                                (val <boolean>))
 831   (and (not (eq? val1 val2))
 832        (make-variable (make-extended-generic (list val2 val1) name))))
 833
 834 (define-method (merge-generics (module <module>)
 835                                (name <symbol>)
 836                                (int1 <module>)
 837                                (val1 <generic>)
 838                                (int2 <module>)
 839                                (val2 <generic>)
 840                                (var <top>)
 841                                (gf <extended-generic>))
 842   (and (not (memq val2 (slot-ref gf 'extends)))
 843        (begin
 844          (slot-set! gf
 845                     'extends
 846                     (cons val2 (delq! val2 (slot-ref gf 'extends))))
 847          (slot-set! val2
 848                     'extended-by
 849                     (cons gf (delq! gf (slot-ref val2 'extended-by))))
 850          var)))
 851
 852 (module-define! duplicate-handlers 'merge-generics merge-generics)
 853
 854 (define-method (merge-accessors (module <module>)
 855                                 (name <symbol>)
 856                                 (int1 <module>)
 857                                 (val1 <top>)
 858                                 (int2 <module>)
 859                                 (val2 <top>)
 860                                 (var <top>)
 861                                 (val <top>))
 862   #f)
 863
 864 (define-method (merge-accessors (module <module>)
 865                                 (name <symbol>)
 866                                 (int1 <module>)
 867                                 (val1 <accessor>)
 868                                 (int2 <module>)
 869                                 (val2 <accessor>)
 870                                 (var <top>)
 871                                 (val <top>))
 872   (merge-generics module name int1 val1 int2 val2 var val))
 873
 874 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
 875
 876 ;;;
 877 ;;; slot access
 878 ;;;
 879
 880 (define (class-slot-g-n-s class slot-name)
 881   (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
 882          (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
 883                           (slot-missing class slot-name)))))
 884     (if (not (memq (slot-definition-allocation this-slot)
 885                    '(#:class #:each-subclass)))
 886         (slot-missing class slot-name))
 887     g-n-s))
 888
 889 (define (class-slot-ref class slot)
 890   (let ((x ((car (class-slot-g-n-s class slot)) #f)))
 891     (if (unbound? x)
 892         (slot-unbound class slot)
 893         x)))
 894
 895 (define (class-slot-set! class slot value)
 896   ((cadr (class-slot-g-n-s class slot)) #f value))
 897
 898 (define-method (slot-unbound (c <class>) (o <object>) s)
 899   (goops-error "Slot `~S' is unbound in object ~S" s o))
 900
 901 (define-method (slot-unbound (c <class>) s)
 902   (goops-error "Slot `~S' is unbound in class ~S" s c))
 903
 904 (define-method (slot-unbound (o <object>))
 905   (goops-error "Unbound slot in object ~S" o))
 906
 907 (define-method (slot-missing (c <class>) (o <object>) s)
 908   (goops-error "No slot with name `~S' in object ~S" s o))
 909
 910 (define-method (slot-missing (c <class>) s)
 911   (goops-error "No class slot with name `~S' in class ~S" s c))
 912
 913
 914 (define-method (slot-missing (c <class>) (o <object>) s value)
 915   (slot-missing c o s))
 916
 917 ;;; Methods for the possible error we can encounter when calling a gf
 918
 919 (define-method (no-next-method (gf <generic>) args)
 920   (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
 921
 922 (define-method (no-applicable-method (gf <generic>) args)
 923   (goops-error "No applicable method for ~S in call ~S"
 924                gf (cons (generic-function-name gf) args)))
 925
 926 (define-method (no-method (gf <generic>) args)
 927   (goops-error "No method defined for ~S"  gf))
 928
 929 ;;;
 930 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
 931 ;;;
 932
 933 (define-method (shallow-clone (self <object>))
 934   (let ((clone (%allocate-instance (class-of self) '()))
 935         (slots (map slot-definition-name
 936                     (class-slots (class-of self)))))
 937     (for-each (lambda (slot)
 938                 (if (slot-bound? self slot)
 939                     (slot-set! clone slot (slot-ref self slot))))
 940               slots)
 941     clone))
 942
 943 (define-method (deep-clone  (self <object>))
 944   (let ((clone (%allocate-instance (class-of self) '()))
 945         (slots (map slot-definition-name
 946                     (class-slots (class-of self)))))
 947     (for-each (lambda (slot)
 948                 (if (slot-bound? self slot)
 949                     (slot-set! clone slot
 950                                (let ((value (slot-ref self slot)))
 951                                  (if (instance? value)
 952                                      (deep-clone value)
 953                                      value)))))
 954               slots)
 955     clone))
 956
 957 ;;;
 958 ;;; {Class redefinition utilities}
 959 ;;;
 960
 961 ;;; (class-redefinition OLD NEW)
 962 ;;;
 963
 964 ;;; Has correct the following conditions:
 965
 966 ;;; Methods
 967 ;;;
 968 ;;; 1. New accessor specializers refer to new header
 969 ;;;
 970 ;;; Classes
 971 ;;;
 972 ;;; 1. New class cpl refers to the new class header
 973 ;;; 2. Old class header exists on old super classes direct-subclass lists
 974 ;;; 3. New class header exists on new super classes direct-subclass lists
 975
 976 (define-method (class-redefinition (old <class>) (new <class>))
 977   ;; Work on direct methods:
 978   ;;            1. Remove accessor methods from the old class
 979   ;;            2. Patch the occurences of new in the specializers by old
 980   ;;            3. Displace the methods from old to new
 981   (remove-class-accessors! old)                                 ;; -1-
 982   (let ((methods (class-direct-methods new)))
 983     (for-each (lambda (m)
 984                  (update-direct-method! m new old))     ;; -2-
 985               methods)
 986     (slot-set! new
 987                'direct-methods
 988                (append methods (class-direct-methods old))))
 989
 990   ;; Substitute old for new in new cpl
 991   (set-car! (slot-ref new 'cpl) old)
 992
 993   ;; Remove the old class from the direct-subclasses list of its super classes
 994   (for-each (lambda (c) (slot-set! c 'direct-subclasses
 995                                    (delv! old (class-direct-subclasses c))))
 996             (class-direct-supers old))
 997
 998   ;; Replace the new class with the old in the direct-subclasses of the supers
 999   (for-each (lambda (c)
1000               (slot-set! c 'direct-subclasses
1001                          (cons old (delv! new (class-direct-subclasses c)))))
1002             (class-direct-supers new))
1003
1004   ;; Swap object headers
1005   (%modify-class old new)
1006
1007   ;; Now old is NEW!
1008
1009   ;; Redefine all the subclasses of old to take into account modification
1010   (for-each
1011        (lambda (c)
1012          (update-direct-subclass! c new old))
1013        (class-direct-subclasses new))
1014
1015   ;; Invalidate class so that subsequent instances slot accesses invoke
1016   ;; change-object-class
1017   (slot-set! new 'redefined old)
1018   (%invalidate-class new) ;must come after slot-set!
1019
1020   old)
1021
1022 ;;;
1023 ;;; remove-class-accessors!
1024 ;;;
1025
1026 (define-method (remove-class-accessors! (c <class>))
1027   (for-each (lambda (m)
1028               (if (is-a? m <accessor-method>)
1029                   (let ((gf (slot-ref m 'generic-function)))
1030                     ;; remove the method from its GF
1031                     (slot-set! gf 'methods
1032                                (delq1! m (slot-ref gf 'methods)))
1033                     (%invalidate-method-cache! gf)
1034                     ;; remove the method from its specializers
1035                     (remove-method-in-classes! m))))
1036             (class-direct-methods c)))
1037
1038 ;;;
1039 ;;; update-direct-method!
1040 ;;;
1041
1042 (define-method (update-direct-method! (m  <method>)
1043                                       (old <class>)
1044                                       (new <class>))
1045   (let loop ((l (method-specializers m)))
1046     ;; Note: the <top> in dotted list is never used.
1047     ;; So we can work as if we had only proper lists.
1048     (if (pair? l)
1049         (begin
1050           (if (eqv? (car l) old)
1051               (set-car! l new))
1052           (loop (cdr l))))))
1053
1054 ;;;
1055 ;;; update-direct-subclass!
1056 ;;;
1057
1058 (define-method (update-direct-subclass! (c <class>)
1059                                         (old <class>)
1060                                         (new <class>))
1061   (class-redefinition c
1062                       (make-class (class-direct-supers c)
1063                                   (class-direct-slots c)
1064                                   #:name (class-name c)
1065                                   #:environment (slot-ref c 'environment)
1066                                   #:metaclass (class-of c))))
1067
1068 ;;;
1069 ;;; {Utilities for INITIALIZE methods}
1070 ;;;
1071
1072 ;;; compute-slot-accessors
1073 ;;;
1074 (define (compute-slot-accessors class slots env)
1075   (for-each
1076       (lambda (s g-n-s)
1077         (let ((name            (slot-definition-name     s))
1078               (getter-function (slot-definition-getter   s))
1079               (setter-function (slot-definition-setter   s))
1080               (accessor        (slot-definition-accessor s)))
1081           (if getter-function
1082               (add-method! getter-function
1083                            (compute-getter-method class g-n-s)))
1084           (if setter-function
1085               (add-method! setter-function
1086                            (compute-setter-method class g-n-s)))
1087           (if accessor
1088               (begin
1089                 (add-method! accessor
1090                              (compute-getter-method class g-n-s))
1091                 (add-method! (setter accessor)
1092                              (compute-setter-method class g-n-s))))))
1093       slots (slot-ref class 'getters-n-setters)))
1094
1095 (define-method (compute-getter-method (class <class>) slotdef)
1096   (let ((init-thunk (cadr slotdef))
1097         (g-n-s (cddr slotdef)))
1098     (make <accessor-method>
1099           #:specializers (list class)
1100           #:procedure (cond ((pair? g-n-s)
1101                              (make-generic-bound-check-getter (car g-n-s)))
1102                             (init-thunk
1103                              (standard-get g-n-s))
1104                             (else
1105                              (bound-check-get g-n-s)))
1106           #:slot-definition slotdef)))
1107
1108 (define-method (compute-setter-method (class <class>) slotdef)
1109   (let ((g-n-s (cddr slotdef)))
1110     (make <accessor-method>
1111           #:specializers (list class <top>)
1112           #:procedure (if (pair? g-n-s)
1113                           (cadr g-n-s)
1114                           (standard-set g-n-s))
1115           #:slot-definition slotdef)))
1116
1117 (define (make-generic-bound-check-getter proc)
1118   (let ((source (and (closure? proc) (procedure-source proc))))
1119     (if (and source (null? (cdddr source)))
1120         (let ((obj (caadr source)))
1121           ;; smart closure compilation
1122           (local-eval
1123            `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
1124            (procedure-environment proc)))
1125         (lambda (o) (assert-bound (proc o) o)))))
1126
1127 ;; the idea is to compile the index into the procedure, for fastest
1128 ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
1129
1130 (eval-when (compile)
1131   (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
1132   (add-interesting-primitive! '@slot-ref)
1133   (add-interesting-primitive! '@slot-set!))
1134
1135 (eval-when (eval load compile)
1136   (define num-standard-pre-cache 20))
1137
1138 (define-macro (define-standard-accessor-method form . body)
1139   (let ((name (caar form))
1140         (n-var (cadar form))
1141         (args (cdr form)))
1142     (define (make-one x)
1143       (define (body-trans form)
1144         (cond ((not (pair? form)) form)
1145               ((eq? (car form) '@slot-ref)
1146                `(,(car form) ,(cadr form) ,x))
1147               ((eq? (car form) '@slot-set!)
1148                `(,(car form) ,(cadr form) ,x ,(cadddr form)))
1149               (else
1150                (map body-trans form))))
1151       `(lambda ,args ,@(map body-trans body)))
1152     `(define ,name
1153        (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
1154          (lambda (n)
1155            (if (< n ,num-standard-pre-cache)
1156                (vector-ref cache n)
1157                ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
1158
1159 (define-standard-accessor-method ((bound-check-get n) o)
1160   (let ((x (@slot-ref o n)))
1161     (if (unbound? x)
1162         (slot-unbound obj)
1163         x)))
1164
1165 (define-standard-accessor-method ((standard-get n) o)
1166   (@slot-ref o n))
1167
1168 (define-standard-accessor-method ((standard-set n) o v)
1169   (@slot-set! o n v))
1170
1171 ;;; compute-getters-n-setters
1172 ;;;
1173 (define (make-thunk thunk)
1174   (lambda () (thunk)))
1175
1176 (define (compute-getters-n-setters class slots env)
1177
1178   (define (compute-slot-init-function name s)
1179     (or (let ((thunk (slot-definition-init-thunk s)))
1180           (and thunk
1181                (cond ((not (thunk? thunk))
1182                       (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
1183                                    name class thunk))
1184                      ((closure? thunk) thunk)
1185                      (else (make-thunk thunk)))))
1186         (let ((init (slot-definition-init-value s)))
1187           (and (not (unbound? init))
1188                (lambda () init)))))
1189
1190   (define (verify-accessors slot l)
1191     (cond ((integer? l))
1192           ((not (and (list? l) (= (length l) 2)))
1193            (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
1194                         slot class l))
1195           (else
1196            (let ((get (car l))
1197                  (set (cadr l)))
1198              ;; note that we allow non-closures; we only check arity on
1199              ;; the closures, though, because we inline their dispatch
1200              ;; in %get-slot-value / %set-slot-value.
1201              (if (or (not (procedure? get))
1202                      (and (closure? get)
1203                           (not (= (car (procedure-property get 'arity)) 1))))
1204                  (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1205                               slot class get))
1206              (if (or (not (procedure? set))
1207                      (and (closure? set)
1208                           (not (= (car (procedure-property set 'arity)) 2))))
1209                  (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1210                               slot class set))))))
1211
1212   (map (lambda (s)
1213          ;; The strange treatment of nfields is due to backward compatibility.
1214          (let* ((index (slot-ref class 'nfields))
1215                 (g-n-s (compute-get-n-set class s))
1216                 (size (- (slot-ref class 'nfields) index))
1217                 (name  (slot-definition-name s)))
1218            ;; NOTE: The following is interdependent with C macros
1219            ;; defined above goops.c:scm_sys_prep_layout_x.
1220            ;;
1221            ;; For simple instance slots, we have the simplest form
1222            ;; '(name init-function . index)
1223            ;; For other slots we have
1224            ;; '(name init-function getter setter . alloc)
1225            ;; where alloc is:
1226            ;;   '(index size) for instance allocated slots
1227            ;;   '() for other slots
1228            (verify-accessors name g-n-s)
1229            (cons name
1230                  (cons (compute-slot-init-function name s)
1231                        (if (or (integer? g-n-s)
1232                                (zero? size))
1233                            g-n-s
1234                            (append g-n-s (list index size)))))))
1235        slots))
1236
1237 ;;; compute-cpl
1238 ;;;
1239 ;;; Correct behaviour:
1240 ;;;
1241 ;;; (define-class food ())
1242 ;;; (define-class fruit (food))
1243 ;;; (define-class spice (food))
1244 ;;; (define-class apple (fruit))
1245 ;;; (define-class cinnamon (spice))
1246 ;;; (define-class pie (apple cinnamon))
1247 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1248 ;;;
1249 ;;; (define-class d ())
1250 ;;; (define-class e ())
1251 ;;; (define-class f ())
1252 ;;; (define-class b (d e))
1253 ;;; (define-class c (e f))
1254 ;;; (define-class a (b c))
1255 ;;; => cpl (a) = a b d c e f object top
1256 ;;;
1257
1258 (define-method (compute-cpl (class <class>))
1259   (compute-std-cpl class class-direct-supers))
1260
1261 ;; Support
1262
1263 (define (only-non-null lst)
1264   (filter (lambda (l) (not (null? l))) lst))
1265
1266 (define (compute-std-cpl c get-direct-supers)
1267   (let ((c-direct-supers (get-direct-supers c)))
1268     (merge-lists (list c)
1269                  (only-non-null (append (map class-precedence-list
1270                                              c-direct-supers)
1271                                         (list c-direct-supers))))))
1272
1273 (define (merge-lists reversed-partial-result inputs)
1274   (cond
1275    ((every null? inputs)
1276     (reverse! reversed-partial-result))
1277    (else
1278     (let* ((candidate (lambda (c)
1279                         (and (not (any (lambda (l)
1280                                          (memq c (cdr l)))
1281                                        inputs))
1282                              c)))
1283            (candidate-car (lambda (l)
1284                             (and (not (null? l))
1285                                  (candidate (car l)))))
1286            (next (any candidate-car inputs)))
1287       (if (not next)
1288           (goops-error "merge-lists: Inconsistent precedence graph"))
1289       (let ((remove-next (lambda (l)
1290                            (if (eq? (car l) next)
1291                                (cdr l)
1292                              l))))
1293         (merge-lists (cons next reversed-partial-result)
1294                      (only-non-null (map remove-next inputs))))))))
1295
1296 ;; Modified from TinyClos:
1297 ;;
1298 ;; A simple topological sort.
1299 ;;
1300 ;; It's in this file so that both TinyClos and Objects can use it.
1301 ;;
1302 ;; This is a fairly modified version of code I originally got from Anurag
1303 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1304 ;;
1305
1306 (define (compute-clos-cpl c get-direct-supers)
1307   (top-sort ((build-transitive-closure get-direct-supers) c)
1308             ((build-constraints get-direct-supers) c)
1309             (std-tie-breaker get-direct-supers)))
1310
1311
1312 (define (top-sort elements constraints tie-breaker)
1313   (let loop ((elements    elements)
1314              (constraints constraints)
1315              (result      '()))
1316     (if (null? elements)
1317         result
1318         (let ((can-go-in-now
1319                (filter
1320                 (lambda (x)
1321                   (every (lambda (constraint)
1322                            (or (not (eq? (cadr constraint) x))
1323                                (memq (car constraint) result)))
1324                          constraints))
1325                 elements)))
1326           (if (null? can-go-in-now)
1327               (goops-error "top-sort: Invalid constraints")
1328               (let ((choice (if (null? (cdr can-go-in-now))
1329                                 (car can-go-in-now)
1330                                 (tie-breaker result
1331                                              can-go-in-now))))
1332                 (loop
1333                  (filter (lambda (x) (not (eq? x choice)))
1334                          elements)
1335                  constraints
1336                  (append result (list choice)))))))))
1337
1338 (define (std-tie-breaker get-supers)
1339   (lambda (partial-cpl min-elts)
1340     (let loop ((pcpl (reverse partial-cpl)))
1341       (let ((current-elt (car pcpl)))
1342         (let ((ds-of-ce (get-supers current-elt)))
1343           (let ((common (filter (lambda (x)
1344                                       (memq x ds-of-ce))
1345                                     min-elts)))
1346             (if (null? common)
1347                 (if (null? (cdr pcpl))
1348                     (goops-error "std-tie-breaker: Nothing valid")
1349                     (loop (cdr pcpl)))
1350                 (car common))))))))
1351
1352
1353 (define (build-transitive-closure get-follow-ons)
1354   (lambda (x)
1355     (let track ((result '())
1356                 (pending (list x)))
1357       (if (null? pending)
1358           result
1359           (let ((next (car pending)))
1360             (if (memq next result)
1361                 (track result (cdr pending))
1362                 (track (cons next result)
1363                        (append (get-follow-ons next)
1364                                (cdr pending)))))))))
1365
1366 (define (build-constraints get-follow-ons)
1367   (lambda (x)
1368     (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1369                (this-one '())
1370                (result '()))
1371       (if (or (null? this-one) (null? (cdr this-one)))
1372           (if (null? elements)
1373               result
1374               (loop (cdr elements)
1375                     (cons (car elements)
1376                           (get-follow-ons (car elements)))
1377                     result))
1378           (loop elements
1379                 (cdr this-one)
1380                 (cons (list (car this-one) (cadr this-one))
1381                       result))))))
1382
1383 ;;; compute-get-n-set
1384 ;;;
1385 (define-method (compute-get-n-set (class <class>) s)
1386   (case (slot-definition-allocation s)
1387     ((#:instance) ;; Instance slot
1388      ;; get-n-set is just its offset
1389      (let ((already-allocated (slot-ref class 'nfields)))
1390        (slot-set! class 'nfields (+ already-allocated 1))
1391        already-allocated))
1392
1393     ((#:class)  ;; Class slot
1394      ;; Class-slots accessors are implemented as 2 closures around
1395      ;; a Scheme variable. As instance slots, class slots must be
1396      ;; unbound at init time.
1397      (let ((name (slot-definition-name s)))
1398        (if (memq name (map slot-definition-name (class-direct-slots class)))
1399            ;; This slot is direct; create a new shared variable
1400            (make-closure-variable class)
1401            ;; Slot is inherited. Find its definition in superclass
1402            (let loop ((l (cdr (class-precedence-list class))))
1403              (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1404                (if r
1405                    (cddr r)
1406                    (loop (cdr l))))))))
1407
1408     ((#:each-subclass) ;; slot shared by instances of direct subclass.
1409      ;; (Thomas Buerger, April 1998)
1410      (make-closure-variable class))
1411
1412     ((#:virtual) ;; No allocation
1413      ;; slot-ref and slot-set! function must be given by the user
1414      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
1415            (set (get-keyword #:slot-set! (slot-definition-options s) #f))
1416            (env (class-environment class)))
1417        (if (not (and get set))
1418            (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
1419                         s))
1420        (list get set)))
1421     (else    (next-method))))
1422
1423 (define (make-closure-variable class)
1424   (let ((shared-variable (make-unbound)))
1425     (list (lambda (o) shared-variable)
1426           (lambda (o v) (set! shared-variable v)))))
1427
1428 (define-method (compute-get-n-set (o <object>) s)
1429   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1430
1431 (define-method (compute-slots (class <class>))
1432   (%compute-slots class))
1433
1434 ;;;
1435 ;;; {Initialize}
1436 ;;;
1437
1438 (define-method (initialize (object <object>) initargs)
1439   (%initialize-object object initargs))
1440
1441 (define-method (initialize (class <class>) initargs)
1442   (next-method)
1443   (let ((dslots (get-keyword #:slots initargs '()))
1444         (supers (get-keyword #:dsupers    initargs '()))
1445         (env    (get-keyword #:environment initargs (top-level-env))))
1446
1447     (slot-set! class 'name              (get-keyword #:name initargs '???))
1448     (slot-set! class 'direct-supers     supers)
1449     (slot-set! class 'direct-slots      dslots)
1450     (slot-set! class 'direct-subclasses '())
1451     (slot-set! class 'direct-methods    '())
1452     (slot-set! class 'cpl               (compute-cpl class))
1453     (slot-set! class 'redefined         #f)
1454     (slot-set! class 'environment       env)
1455     (let ((slots (compute-slots class)))
1456       (slot-set! class 'slots             slots)
1457       (slot-set! class 'nfields           0)
1458       (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1459                                                                      slots
1460                                                                      env))
1461       ;; Build getters - setters - accessors
1462       (compute-slot-accessors class slots env))
1463
1464     ;; Update the "direct-subclasses" of each inherited classes
1465     (for-each (lambda (x)
1466                 (slot-set! x
1467                            'direct-subclasses
1468                            (cons class (slot-ref x 'direct-subclasses))))
1469               supers)
1470
1471     ;; Support for the underlying structs:
1472
1473     ;; Inherit class flags (invisible on scheme level) from supers
1474     (%inherit-magic! class supers)
1475
1476     ;; Set the layout slot
1477     (%prep-layout! class)))
1478
1479 (define (initialize-object-procedure object initargs)
1480   (let ((proc (get-keyword #:procedure initargs #f)))
1481     (cond ((not proc))
1482           ((pair? proc)
1483            (apply set-object-procedure! object proc))
1484           ((valid-object-procedure? proc)
1485            (set-object-procedure! object proc))
1486           (else
1487            (set-object-procedure! object
1488                                   (lambda args (apply proc args)))))))
1489
1490 (define-method (initialize (class <operator-class>) initargs)
1491   (next-method)
1492   (initialize-object-procedure class initargs))
1493
1494 (define-method (initialize (owsc <operator-with-setter-class>) initargs)
1495   (next-method)
1496   (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1497
1498 (define-method (initialize (entity <entity>) initargs)
1499   (next-method)
1500   (initialize-object-procedure entity initargs))
1501
1502 (define-method (initialize (ews <entity-with-setter>) initargs)
1503   (next-method)
1504   (%set-object-setter! ews (get-keyword #:setter initargs #f)))
1505
1506 (define-method (initialize (generic <generic>) initargs)
1507   (let ((previous-definition (get-keyword #:default initargs #f))
1508         (name (get-keyword #:name initargs #f)))
1509     (next-method)
1510     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1511                                     (list (method args
1512                                             (apply previous-definition args)))
1513                                     '()))
1514     (if name
1515         (set-procedure-property! generic 'name name))
1516     ))
1517
1518 (define-method (initialize (eg <extended-generic>) initargs)
1519   (next-method)
1520   (slot-set! eg 'extends (get-keyword #:extends initargs '())))
1521
1522 (define dummy-procedure (lambda args *unspecified*))
1523
1524 (define-method (initialize (method <method>) initargs)
1525   (next-method)
1526   (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1527   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1528   (slot-set! method 'procedure
1529              (get-keyword #:procedure initargs #f))
1530   (slot-set! method 'code-table '())
1531   (slot-set! method 'formals (get-keyword #:formals initargs '()))
1532   (slot-set! method 'body (get-keyword #:body initargs '()))
1533   (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
1534
1535
1536 (define-method (initialize (obj <foreign-object>) initargs))
1537
1538 ;;;
1539 ;;; {Change-class}
1540 ;;;
1541
1542 (define (change-object-class old-instance old-class new-class)
1543   (let ((new-instance (allocate-instance new-class '())))
1544     ;; Initialize the slots of the new instance
1545     (for-each (lambda (slot)
1546                 (if (and (slot-exists-using-class? old-class old-instance slot)
1547                          (eq? (slot-definition-allocation
1548                                (class-slot-definition old-class slot))
1549                               #:instance)
1550                          (slot-bound-using-class? old-class old-instance slot))
1551                     ;; Slot was present and allocated in old instance; copy it
1552                     (slot-set-using-class!
1553                      new-class
1554                      new-instance
1555                      slot
1556                      (slot-ref-using-class old-class old-instance slot))
1557                     ;; slot was absent; initialize it with its default value
1558                     (let ((init (slot-init-function new-class slot)))
1559                       (if init
1560                           (slot-set-using-class!
1561                                new-class
1562                                new-instance
1563                                slot
1564                                (apply init '()))))))
1565               (map slot-definition-name (class-slots new-class)))
1566     ;; Exchange old and new instance in place to keep pointers valid
1567     (%modify-instance old-instance new-instance)
1568     ;; Allow class specific updates of instances (which now are swapped)
1569     (update-instance-for-different-class new-instance old-instance)
1570     old-instance))
1571
1572
1573 (define-method (update-instance-for-different-class (old-instance <object>)
1574                                                     (new-instance
1575                                                      <object>))
1576   ;;not really important what we do, we just need a default method
1577   new-instance)
1578
1579 (define-method (change-class (old-instance <object>) (new-class <class>))
1580   (change-object-class old-instance (class-of old-instance) new-class))
1581
1582 ;;;
1583 ;;; {make}
1584 ;;;
1585 ;;; A new definition which overwrites the previous one which was built-in
1586 ;;;
1587
1588 (define-method (allocate-instance (class <class>) initargs)
1589   (%allocate-instance class initargs))
1590
1591 (define-method (make-instance (class <class>) . initargs)
1592   (let ((instance (allocate-instance class initargs)))
1593     (initialize instance initargs)
1594     instance))
1595
1596 (define make make-instance)
1597
1598 ;;;
1599 ;;; {apply-generic}
1600 ;;;
1601 ;;; Protocol for calling standard generic functions.  This protocol is
1602 ;;; not used for real <generic> functions (in this case we use a
1603 ;;; completely C hard-coded protocol).  Apply-generic is used by
1604 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1605 ;;; The code below is similar to the first MOP described in AMOP. In
1606 ;;; particular, it doesn't used the currified approach to gf
1607 ;;; call. There are 2 reasons for that:
1608 ;;;   - the protocol below is exposed to mimic completely the one written in C
1609 ;;;   - the currified protocol would be imho inefficient in C.
1610 ;;;
1611
1612 (define-method (apply-generic (gf <generic>) args)
1613   (if (null? (slot-ref gf 'methods))
1614       (no-method gf args))
1615   (let ((methods (compute-applicable-methods gf args)))
1616     (if methods
1617         (apply-methods gf (sort-applicable-methods gf methods args) args)
1618         (no-applicable-method gf args))))
1619
1620 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1621 ;; *fixme* use let
1622 (define %%compute-applicable-methods
1623   (make <generic> #:name 'compute-applicable-methods))
1624
1625 (define-method (%%compute-applicable-methods (gf <generic>) args)
1626   (%compute-applicable-methods gf args))
1627
1628 (set! compute-applicable-methods %%compute-applicable-methods)
1629
1630 (define-method (sort-applicable-methods (gf <generic>) methods args)
1631   (let ((targs (map class-of args)))
1632     (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1633
1634 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1635   (%method-more-specific? m1 m2 targs))
1636
1637 (define-method (apply-method (gf <generic>) methods build-next args)
1638   (apply (method-procedure (car methods))
1639          (build-next (cdr methods) args)
1640          args))
1641
1642 (define-method (apply-methods (gf <generic>) (l <list>) args)
1643   (letrec ((next (lambda (procs args)
1644                    (lambda new-args
1645                      (let ((a (if (null? new-args) args new-args)))
1646                        (if (null? procs)
1647                            (no-next-method gf a)
1648                            (apply-method gf procs next a)))))))
1649     (apply-method gf l next args)))
1650
1651 ;; We don't want the following procedure to turn up in backtraces:
1652 (for-each (lambda (proc)
1653             (set-procedure-property! proc 'system-procedure #t))
1654           (list slot-unbound
1655                 slot-missing
1656                 no-next-method
1657                 no-applicable-method
1658                 no-method
1659                 ))
1660
1661 ;;;
1662 ;;; {<composite-metaclass> and <active-metaclass>}
1663 ;;;
1664
1665 ;(autoload "active-slot"    <active-metaclass>)
1666 ;(autoload "composite-slot" <composite-metaclass>)
1667 ;(export <composite-metaclass> <active-metaclass>)
1668
1669 ;;;
1670 ;;; {Tools}
1671 ;;;
1672
1673 ;; list2set
1674 ;;
1675 ;; duplicate the standard list->set function but using eq instead of
1676 ;; eqv which really sucks a lot, uselessly here
1677 ;;
1678 (define (list2set l)
1679   (let loop ((l l)
1680              (res '()))
1681     (cond
1682      ((null? l) res)
1683      ((memq (car l) res) (loop (cdr l) res))
1684      (else (loop (cdr l) (cons (car l) res))))))
1685
1686 (define (class-subclasses c)
1687   (letrec ((allsubs (lambda (c)
1688                       (cons c (mapappend allsubs
1689                                          (class-direct-subclasses c))))))
1690     (list2set (cdr (allsubs c)))))
1691
1692 (define (class-methods c)
1693   (list2set (mapappend class-direct-methods
1694                        (cons c (class-subclasses c)))))
1695
1696 ;;;
1697 ;;; {Final initialization}
1698 ;;;
1699
1700 ;; Tell C code that the main bulk of Goops has been loaded
1701 (%goops-loaded)