module/oop/goops.scm

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