module/oop/goops.scm

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