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