module/oop/goops.scm

   1 ;;; installed-scm-file
   2
   3 ;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
   4 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19 ;;;;
  20 \f
  21
  22 ;;;;
  23 ;;;; This file was based upon stklos.stk from the STk distribution
  24 ;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
  25 ;;;;
  26
  27 (define-module (oop goops)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (ice-9 match)
  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 ( ;; The root of everything.
  35             <top>
  36             <class> <object>
  37
  38             ;; Slot types.
  39             <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
  40             <read-only-slot> <self-slot> <protected-opaque-slot>
  41             <protected-hidden-slot> <protected-read-only-slot>
  42             <scm-slot> <int-slot> <float-slot> <double-slot>
  43
  44             ;; Methods are implementations of generic functions.
  45             <method> <accessor-method>
  46
  47             ;; Applicable objects, either procedures or applicable structs.
  48             <procedure-class> <applicable>
  49             <procedure> <primitive-generic>
  50
  51             ;; Applicable structs.
  52             <applicable-struct-class>
  53             <applicable-struct>
  54             <generic> <extended-generic>
  55             <generic-with-setter> <extended-generic-with-setter>
  56             <accessor> <extended-accessor>
  57
  58             ;; Types with their own allocated typecodes.
  59             <boolean> <char> <list> <pair> <null> <string> <symbol>
  60             <vector> <bytevector> <uvec> <foreign> <hashtable>
  61             <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
  62             <keyword>
  63
  64             ;; Numbers.
  65             <number> <complex> <real> <integer> <fraction>
  66
  67             ;; Unknown.
  68             <unknown>
  69
  70             ;; Particular SMOB data types.  All SMOB types have
  71             ;; corresponding classes, which may be obtained via class-of,
  72             ;; once you have an instance.  Perhaps FIXME to provide a
  73             ;; smob-type-name->class procedure.
  74             <arbiter> <promise> <thread> <mutex> <condition-variable>
  75             <regexp> <hook> <bitvector> <random-state> <async>
  76             <directory> <array> <character-set>
  77             <dynamic-object> <guardian> <macro>
  78
  79             ;; Modules.
  80             <module>
  81
  82             ;; Ports.
  83             <port> <input-port> <output-port> <input-output-port>
  84
  85             ;; Like SMOB types, all port types have their own classes,
  86             ;; which can be accessed via `class-of' once you have an
  87             ;; instance.  Here we export bindings just for file ports.
  88             <file-port>
  89             <file-input-port> <file-output-port> <file-input-output-port>
  90
  91             is-a? class-of
  92             ensure-metaclass ensure-metaclass-with-supers
  93             make-class
  94             make-generic ensure-generic
  95             make-extended-generic
  96             make-accessor ensure-accessor
  97             add-method!
  98             class-slot-ref class-slot-set! slot-unbound slot-missing
  99             slot-definition-name  slot-definition-options
 100             slot-definition-allocation
 101
 102             slot-definition-getter slot-definition-setter
 103             slot-definition-accessor
 104             slot-definition-init-value slot-definition-init-form
 105             slot-definition-init-thunk slot-definition-init-keyword
 106             slot-init-function class-slot-definition
 107             method-source
 108             compute-cpl compute-std-cpl compute-get-n-set compute-slots
 109             compute-getter-method compute-setter-method
 110             allocate-instance initialize make-instance make
 111             no-next-method  no-applicable-method no-method
 112             change-class update-instance-for-different-class
 113             shallow-clone deep-clone
 114             class-redefinition
 115             apply-generic apply-method apply-methods
 116             compute-applicable-methods %compute-applicable-methods
 117             method-more-specific? sort-applicable-methods
 118             class-subclasses class-methods
 119             goops-error
 120             min-fixnum max-fixnum
 121
 122 ;;; *fixme* Should go into goops.c
 123             instance?  slot-ref-using-class
 124             slot-set-using-class! slot-bound-using-class?
 125             slot-exists-using-class? slot-ref slot-set! slot-bound?
 126             class-name class-direct-supers class-direct-subclasses
 127             class-direct-methods class-direct-slots class-precedence-list
 128             class-slots
 129             generic-function-name
 130             generic-function-methods method-generic-function
 131             method-specializers method-formals
 132             primitive-generic-generic enable-primitive-generic!
 133             method-procedure accessor-method-slot-definition
 134             slot-exists? make find-method get-keyword)
 135   #:no-backtrace)
 136
 137 (define *goops-module* (current-module))
 138
 139 (eval-when (compile load eval)
 140   ;;; The standard class precedence list computation algorithm
 141   ;;;
 142   ;;; Correct behaviour:
 143   ;;;
 144   ;;; (define-class food ())
 145   ;;; (define-class fruit (food))
 146   ;;; (define-class spice (food))
 147   ;;; (define-class apple (fruit))
 148   ;;; (define-class cinnamon (spice))
 149   ;;; (define-class pie (apple cinnamon))
 150   ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
 151   ;;;
 152   ;;; (define-class d ())
 153   ;;; (define-class e ())
 154   ;;; (define-class f ())
 155   ;;; (define-class b (d e))
 156   ;;; (define-class c (e f))
 157   ;;; (define-class a (b c))
 158   ;;; => cpl (a) = a b d c e f object top
 159   ;;;
 160
 161   (define (compute-std-cpl c get-direct-supers)
 162     (define (only-non-null lst)
 163       (filter (lambda (l) (not (null? l))) lst))
 164
 165     (define (merge-lists reversed-partial-result inputs)
 166       (cond
 167        ((every null? inputs)
 168         (reverse! reversed-partial-result))
 169        (else
 170         (let* ((candidate (lambda (c)
 171                             (and (not (any (lambda (l)
 172                                              (memq c (cdr l)))
 173                                            inputs))
 174                                  c)))
 175                (candidate-car (lambda (l)
 176                                 (and (not (null? l))
 177                                      (candidate (car l)))))
 178                (next (any candidate-car inputs)))
 179           (if (not next)
 180               (goops-error "merge-lists: Inconsistent precedence graph"))
 181           (let ((remove-next (lambda (l)
 182                                (if (eq? (car l) next)
 183                                    (cdr l)
 184                                    l))))
 185             (merge-lists (cons next reversed-partial-result)
 186                          (only-non-null (map remove-next inputs))))))))
 187     (let ((c-direct-supers (get-direct-supers c)))
 188       (merge-lists (list c)
 189                    (only-non-null (append (map class-precedence-list
 190                                                c-direct-supers)
 191                                           (list c-direct-supers))))))
 192
 193   ;; Bootstrap version.
 194   (define (compute-cpl class)
 195     (compute-std-cpl class class-direct-supers)))
 196
 197 ;; XXX FIXME: figure out why the 'eval-when's in this file must use
 198 ;; 'compile' and must avoid 'expand', but only in 2.2, and only when
 199 ;; compiling something that imports goops, e.g. (ice-9 occam-channel),
 200 ;; before (oop goops) itself has been compiled.
 201
 202 ;; First initialize the builtin part of GOOPS
 203 (eval-when (compile load eval)
 204   (load-extension (string-append "libguile-" (effective-version))
 205                   "scm_init_goops_builtins"))
 206
 207 (eval-when (compile load eval)
 208   (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
 209   (add-interesting-primitive! 'class-of))
 210
 211 ;; During boot, the specialized slot classes aren't defined yet, so we
 212 ;; initialize <class> with unspecialized slots.
 213 (define-syntax-rule (build-<class>-slots specialized?)
 214   (let-syntax ((unspecialized-slot (syntax-rules ()
 215                                      ((_ name) (list 'name))))
 216                (specialized-slot (syntax-rules ()
 217                                    ((_ name class)
 218                                     (if specialized?
 219                                         (list 'name #:class class)
 220                                         (list 'name))))))
 221     (list (specialized-slot layout <protected-read-only-slot>)
 222           (specialized-slot flags <hidden-slot>)
 223           (specialized-slot self <self-slot>)
 224           (specialized-slot instance-finalizer <hidden-slot>)
 225           (unspecialized-slot print)
 226           (specialized-slot name <protected-hidden-slot>)
 227           (specialized-slot reserved-0 <hidden-slot>)
 228           (specialized-slot reserved-1 <hidden-slot>)
 229           (unspecialized-slot redefined)
 230           (specialized-slot h0 <int-slot>)
 231           (specialized-slot h1 <int-slot>)
 232           (specialized-slot h2 <int-slot>)
 233           (specialized-slot h3 <int-slot>)
 234           (specialized-slot h4 <int-slot>)
 235           (specialized-slot h5 <int-slot>)
 236           (specialized-slot h6 <int-slot>)
 237           (specialized-slot h7 <int-slot>)
 238           (unspecialized-slot direct-supers)
 239           (unspecialized-slot direct-slots)
 240           (unspecialized-slot direct-subclasses)
 241           (unspecialized-slot direct-methods)
 242           (unspecialized-slot cpl)
 243           (unspecialized-slot default-slot-definition-class)
 244           (unspecialized-slot slots)
 245           (unspecialized-slot getters-n-setters)
 246           (unspecialized-slot nfields))))
 247
 248 (eval-when (compile load eval)
 249   (define (build-slots-list dslots cpl)
 250     (define (check-cpl slots class-slots)
 251       (when (or-map (lambda (slot-def) (assq (car slot-def) slots))
 252                     class-slots)
 253         (scm-error 'misc-error #f
 254                    "a predefined <class> inherited field cannot be redefined"
 255                    '() '())))
 256     (define (remove-duplicate-slots slots)
 257       (let lp ((slots (reverse slots)) (res '()) (seen '()))
 258         (cond
 259          ((null? slots) res)
 260          ((memq (caar slots) seen)
 261           (lp (cdr slots) res seen))
 262          (else
 263           (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
 264     (let* ((class-slots (and (memq <class> cpl) (slot-ref <class> 'slots))))
 265       (when class-slots
 266         (check-cpl dslots class-slots))
 267       (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
 268         (if (null? cpl)
 269             (remove-duplicate-slots (append class-slots res))
 270             (let* ((head (car cpl))
 271                    (cpl (cdr cpl))
 272                    (new-slots (slot-ref head 'direct-slots)))
 273               (cond
 274                ((not class-slots)
 275                 (lp cpl (append new-slots res) class-slots))
 276                ((eq? head <class>)
 277                 ;; Move class slots to the head of the list.
 278                 (lp cpl res new-slots))
 279                (else
 280                 (check-cpl new-slots class-slots)
 281                 (lp cpl (append new-slots res) class-slots))))))))
 282
 283   (define (%compute-getters-n-setters slots)
 284     (define (compute-init-thunk options)
 285       (cond
 286        ((kw-arg-ref options #:init-value) => (lambda (val) (lambda () val)))
 287        ((kw-arg-ref options #:init-thunk))
 288        (else #f)))
 289     (let lp ((slots slots) (n 0))
 290       (match slots
 291         (() '())
 292         (((name . options) . slots)
 293          (cons (cons name (cons (compute-init-thunk options) n))
 294                (lp slots (1+ n)))))))
 295
 296   (define (%compute-layout slots getters-n-setters nfields is-class?)
 297     (define (instance-allocated? g-n-s)
 298       (match g-n-s
 299         ((name init-thunk . (? exact-integer? index)) #t)
 300         ((name init-thunk getter setter index size) #t)
 301         (_ #f)))
 302
 303     (define (allocated-index g-n-s)
 304       (match g-n-s
 305         ((name init-thunk . (? exact-integer? index)) index)
 306         ((name init-thunk getter setter index size) index)))
 307
 308     (define (allocated-size g-n-s)
 309       (match g-n-s
 310         ((name init-thunk . (? exact-integer? index)) 1)
 311         ((name init-thunk getter setter index size) size)))
 312
 313     (define (slot-protection-and-kind options)
 314       (define (subclass? class parent)
 315         (memq parent (class-precedence-list class)))
 316       (let ((type (kw-arg-ref options #:class)))
 317         (if (and type (subclass? type <foreign-slot>))
 318             (values (cond
 319                      ((subclass? type <self-slot>) #\s)
 320                      ((subclass? type <protected-slot>) #\p)
 321                      (else #\u))
 322                     (cond
 323                      ((subclass? type <opaque-slot>) #\o)
 324                      ((subclass? type <read-only-slot>) #\r)
 325                      ((subclass? type <hidden-slot>) #\h)
 326                      (else #\w)))
 327             (values #\p #\w))))
 328
 329     (let ((layout (make-string (* nfields 2))))
 330       (let lp ((n 0) (slots slots) (getters-n-setters getters-n-setters))
 331         (match getters-n-setters
 332           (()
 333            (unless (= n nfields) (error "bad nfields"))
 334            (unless (null? slots) (error "inconsistent g-n-s/slots"))
 335            (when is-class?
 336              (let ((class-layout (symbol->string (slot-ref <class> 'layout))))
 337                (unless (string-prefix? class-layout layout)
 338                  (error "bad layout for class"))))
 339            layout)
 340           ((g-n-s . getters-n-setters)
 341            (match slots
 342              (((name . options) . slots)
 343               (cond
 344                ((instance-allocated? g-n-s)
 345                 (unless (< n nfields) (error "bad nfields"))
 346                 (unless (= n (allocated-index g-n-s)) (error "bad allocation"))
 347                 (call-with-values (lambda () (slot-protection-and-kind options))
 348                   (lambda (protection kind)
 349                     (let init ((n n) (size (allocated-size g-n-s)))
 350                       (cond
 351                        ((zero? size) (lp n slots getters-n-setters))
 352                        (else
 353                         (string-set! layout (* n 2) protection)
 354                         (string-set! layout (1+ (* n 2)) kind)
 355                         (init (1+ n) (1- size))))))))
 356                (else
 357                 (lp n slots getters-n-setters))))))))))
 358
 359   (define (%prep-layout! class)
 360     (let* ((is-class? (and (memq <class> (slot-ref class 'cpl)) #t))
 361            (layout (%compute-layout (slot-ref class 'slots)
 362                                     (slot-ref class 'getters-n-setters)
 363                                     (slot-ref class 'nfields)
 364                                     is-class?)))
 365       (%init-layout! class layout)))
 366
 367   (define (make-standard-class class name dsupers dslots)
 368     (let ((z (make-struct/no-tail class)))
 369       (slot-set! z 'direct-supers dsupers)
 370       (let* ((cpl (compute-cpl z))
 371              (dslots (map (lambda (slot)
 372                             (if (pair? slot) slot (list slot)))
 373                           dslots))
 374              (slots (build-slots-list dslots cpl))
 375              (nfields (length slots))
 376              (g-n-s (%compute-getters-n-setters slots)))
 377         (slot-set! z 'name name)
 378         (slot-set! z 'direct-slots dslots)
 379         (slot-set! z 'direct-subclasses '())
 380         (slot-set! z 'direct-methods '())
 381         (slot-set! z 'cpl cpl)
 382         (slot-set! z 'slots slots)
 383         (slot-set! z 'nfields nfields)
 384         (slot-set! z 'getters-n-setters g-n-s)
 385         (slot-set! z 'redefined #f)
 386         (for-each (lambda (super)
 387                     (let ((subclasses (slot-ref super 'direct-subclasses)))
 388                       (slot-set! super 'direct-subclasses (cons z subclasses))))
 389                   dsupers)
 390         (%prep-layout! z)
 391         (%inherit-magic! z dsupers)
 392         z)))
 393
 394   (define <class>
 395     (let ((dslots (build-<class>-slots #f)))
 396       (%make-root-class '<class> dslots (%compute-getters-n-setters dslots))))
 397
 398   (define-syntax define-standard-class
 399     (syntax-rules ()
 400       ((define-standard-class name (super ...) #:metaclass meta slot ...)
 401        (define name
 402          (make-standard-class meta 'name (list super ...) '(slot ...))))
 403       ((define-standard-class name (super ...) slot ...)
 404        (define-standard-class name (super ...) #:metaclass <class> slot ...))))
 405
 406   (define-standard-class <top> ())
 407   (define-standard-class <object> (<top>))
 408
 409   ;; <top>, <object>, and <class> were partially initialized.  Correct
 410   ;; them here.
 411   (slot-set! <object> 'direct-subclasses (list <class>))
 412   (slot-set! <class> 'direct-supers (list <object>))
 413   (slot-set! <class> 'cpl (list <class> <object> <top>))
 414
 415   (define-standard-class <foreign-slot> (<top>))
 416   (define-standard-class <protected-slot> (<foreign-slot>))
 417   (define-standard-class <hidden-slot> (<foreign-slot>))
 418   (define-standard-class <opaque-slot> (<foreign-slot>))
 419   (define-standard-class <read-only-slot> (<foreign-slot>))
 420   (define-standard-class <self-slot> (<read-only-slot>))
 421   (define-standard-class <protected-opaque-slot> (<protected-slot>
 422                                                   <opaque-slot>))
 423   (define-standard-class <protected-hidden-slot> (<protected-slot>
 424                                                   <hidden-slot>))
 425   (define-standard-class <protected-read-only-slot> (<protected-slot>
 426                                                      <read-only-slot>))
 427   (define-standard-class <scm-slot> (<protected-slot>))
 428   (define-standard-class <int-slot> (<foreign-slot>))
 429   (define-standard-class <float-slot> (<foreign-slot>))
 430   (define-standard-class <double-slot> (<foreign-slot>))
 431
 432   ;; Finish initialization of <class>.
 433   (let ((dslots (build-<class>-slots #t)))
 434     (slot-set! <class> 'direct-slots dslots)
 435     (slot-set! <class> 'slots dslots)
 436     (slot-set! <class> 'getters-n-setters (%compute-getters-n-setters dslots)))
 437
 438   ;; Applicables and their classes.
 439   (define-standard-class <procedure-class> (<class>))
 440   (define-standard-class <applicable-struct-class> (<procedure-class>))
 441   (%bless-applicable-struct-vtable! <applicable-struct-class>)
 442   (define-standard-class <method> (<object>)
 443     generic-function
 444     specializers
 445     procedure
 446     formals
 447     body
 448     make-procedure)
 449   (define-standard-class <accessor-method> (<method>)
 450     (slot-definition #:init-keyword #:slot-definition))
 451   (define-standard-class <applicable> (<top>))
 452   (define-standard-class <applicable-struct> (<object> <applicable>)
 453     #:metaclass <applicable-struct-class>
 454     procedure)
 455   (define-standard-class <generic> (<applicable-struct>)
 456     #:metaclass <applicable-struct-class>
 457     methods
 458     (n-specialized #:init-value 0)
 459     (extended-by #:init-value ())
 460     effective-methods)
 461   (%bless-pure-generic-vtable! <generic>)
 462   (define-standard-class <extended-generic> (<generic>)
 463     #:metaclass <applicable-struct-class>
 464     (extends #:init-value ()))
 465   (%bless-pure-generic-vtable! <extended-generic>)
 466   (define-standard-class <generic-with-setter> (<generic>)
 467     #:metaclass <applicable-struct-class>
 468     setter)
 469   (%bless-pure-generic-vtable! <generic-with-setter>)
 470   (define-standard-class <accessor> (<generic-with-setter>)
 471     #:metaclass <applicable-struct-class>)
 472   (%bless-pure-generic-vtable! <accessor>)
 473   (define-standard-class <extended-generic-with-setter> (<extended-generic>
 474                                                          <generic-with-setter>)
 475     #:metaclass <applicable-struct-class>)
 476   (%bless-pure-generic-vtable! <extended-generic-with-setter>)
 477   (define-standard-class <extended-accessor> (<accessor>
 478                                               <extended-generic-with-setter>)
 479     #:metaclass <applicable-struct-class>)
 480   (%bless-pure-generic-vtable! <extended-accessor>)
 481
 482   ;; Primitive types classes
 483   (define-standard-class <boolean> (<top>))
 484   (define-standard-class <char> (<top>))
 485   (define-standard-class <list> (<top>))
 486   ;; Not all pairs are lists, but there is code out there that relies on
 487   ;; (is-a? '(1 2 3) <list>) to work.  Terrible.  How to fix?
 488   (define-standard-class <pair> (<list>))
 489   (define-standard-class <null> (<list>))
 490   (define-standard-class <string> (<top>))
 491   (define-standard-class <symbol> (<top>))
 492   (define-standard-class <vector> (<top>))
 493   (define-standard-class <foreign> (<top>))
 494   (define-standard-class <hashtable> (<top>))
 495   (define-standard-class <fluid> (<top>))
 496   (define-standard-class <dynamic-state> (<top>))
 497   (define-standard-class <frame> (<top>))
 498   (define-standard-class <vm-continuation> (<top>))
 499   (define-standard-class <bytevector> (<top>))
 500   (define-standard-class <uvec> (<bytevector>))
 501   (define-standard-class <array> (<top>))
 502   (define-standard-class <bitvector> (<top>))
 503   (define-standard-class <number> (<top>))
 504   (define-standard-class <complex> (<number>))
 505   (define-standard-class <real> (<complex>))
 506   (define-standard-class <integer> (<real>))
 507   (define-standard-class <fraction> (<real>))
 508   (define-standard-class <keyword> (<top>))
 509   (define-standard-class <unknown> (<top>))
 510   (define-standard-class <procedure> (<applicable>)
 511     #:metaclass <procedure-class>)
 512   (define-standard-class <primitive-generic> (<procedure>)
 513     #:metaclass <procedure-class>)
 514   (define-standard-class <port> (<top>))
 515   (define-standard-class <input-port> (<port>))
 516   (define-standard-class <output-port> (<port>))
 517   (define-standard-class <input-output-port> (<input-port> <output-port>))
 518   )
 519
 520 (eval-when (compile load eval)
 521   (%goops-early-init))
 522
 523 ;; Then load the rest of GOOPS
 524 (use-modules (oop goops util)
 525              (oop goops dispatch)
 526              (oop goops compile))
 527
 528 \f
 529 ;; FIXME: deprecate.
 530 (eval-when (compile load eval)
 531   (define min-fixnum (- (expt 2 29)))
 532   (define max-fixnum (- (expt 2 29) 1)))
 533
 534 ;;
 535 ;; goops-error
 536 ;;
 537 (define (goops-error format-string . args)
 538   (scm-error 'goops-error #f format-string args '()))
 539
 540 ;;
 541 ;; is-a?
 542 ;;
 543 (define (is-a? obj class)
 544   (and (memq class (class-precedence-list (class-of obj))) #t))
 545
 546
 547 ;;;
 548 ;;; {Meta classes}
 549 ;;;
 550
 551 (define ensure-metaclass-with-supers
 552   (let ((table-of-metas '()))
 553     (lambda (meta-supers)
 554       (let ((entry (assoc meta-supers table-of-metas)))
 555         (if entry
 556             ;; Found a previously created metaclass
 557             (cdr entry)
 558             ;; Create a new meta-class which inherit from "meta-supers"
 559             (let ((new (make <class> #:dsupers meta-supers
 560                                      #:slots   '()
 561                                      #:name   (gensym "metaclass"))))
 562               (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
 563               new))))))
 564
 565 (define (ensure-metaclass supers)
 566   (if (null? supers)
 567       <class>
 568       (let* ((all-metas (map (lambda (x) (class-of x)) supers))
 569              (all-cpls  (append-map (lambda (m)
 570                                       (cdr (class-precedence-list m)))
 571                                     all-metas))
 572              (needed-metas '()))
 573         ;; Find the most specific metaclasses.  The new metaclass will be
 574         ;; a subclass of these.
 575         (for-each
 576          (lambda (meta)
 577            (if (and (not (member meta all-cpls))
 578                       (not (member meta needed-metas)))
 579              (set! needed-metas (append needed-metas (list meta)))))
 580          all-metas)
 581         ;; Now return a subclass of the metaclasses we found.
 582         (if (null? (cdr needed-metas))
 583             (car needed-metas)  ; If there's only one, just use it.
 584             (ensure-metaclass-with-supers needed-metas)))))
 585
 586 ;;;
 587 ;;; {Classes}
 588 ;;;
 589
 590 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 591 ;;;
 592 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 593 ;;;   OPTION ::= KEYWORD VALUE
 594 ;;;
 595
 596 (define (kw-do-map mapper f kwargs)
 597   (define (keywords l)
 598     (cond
 599      ((null? l) '())
 600      ((or (null? (cdr l)) (not (keyword? (car l))))
 601       (goops-error "malformed keyword arguments: ~a" kwargs))
 602      (else (cons (car l) (keywords (cddr l))))))
 603   (define (args l)
 604     (if (null? l) '() (cons (cadr l) (args (cddr l)))))
 605   ;; let* to check keywords first
 606   (let* ((k (keywords kwargs))
 607          (a (args kwargs)))
 608     (mapper f k a)))
 609
 610 (define (make-class supers slots . options)
 611   (let* ((name (get-keyword #:name options (make-unbound)))
 612          (supers (if (not (or-map (lambda (class)
 613                                     (memq <object>
 614                                           (class-precedence-list class)))
 615                                   supers))
 616                      (append supers (list <object>))
 617                      supers))
 618          (metaclass (or (get-keyword #:metaclass options #f)
 619                         (ensure-metaclass supers))))
 620
 621     ;; Verify that all direct slots are different and that we don't inherit
 622     ;; several time from the same class
 623     (let ((tmp1 (find-duplicate supers))
 624           (tmp2 (find-duplicate (map slot-definition-name slots))))
 625       (if tmp1
 626           (goops-error "make-class: super class ~S is duplicate in class ~S"
 627                        tmp1 name))
 628       (if tmp2
 629           (goops-error "make-class: slot ~S is duplicate in class ~S"
 630                        tmp2 name)))
 631
 632     ;; Everything seems correct, build the class
 633     (apply make metaclass
 634            #:dsupers supers
 635            #:slots slots
 636            #:name name
 637            options)))
 638
 639 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
 640 ;;;
 641 ;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
 642 ;;;   OPTION ::= KEYWORD VALUE
 643 ;;;
 644 (define-macro (class supers . slots)
 645   (define (make-slot-definition-forms slots)
 646     (map
 647      (lambda (def)
 648        (cond
 649         ((pair? def)
 650          `(list ',(car def)
 651                 ,@(kw-do-map append-map
 652                              (lambda (kw arg)
 653                                (case kw
 654                                  ((#:init-form)
 655                                   `(#:init-form ',arg
 656                                     #:init-thunk (lambda () ,arg)))
 657                                  (else (list kw arg))))
 658                              (cdr def))))
 659         (else
 660          `(list ',def))))
 661      slots))
 662   (if (not (list? supers))
 663       (goops-error "malformed superclass list: ~S" supers))
 664   (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
 665         (options (or (find-tail keyword? slots) '())))
 666     `(make-class
 667       ;; evaluate super class variables
 668       (list ,@supers)
 669       ;; evaluate slot definitions, except the slot name!
 670       (list ,@(make-slot-definition-forms slots))
 671       ;; evaluate class options
 672       ,@options)))
 673
 674 (define-syntax define-class-pre-definition
 675   (lambda (x)
 676     (syntax-case x ()
 677       ((_ (k arg rest ...) out ...)
 678        (keyword? (syntax->datum #'k))
 679        (case (syntax->datum #'k)
 680          ((#:getter #:setter)
 681           #'(define-class-pre-definition (rest ...)
 682               out ...
 683               (if (or (not (defined? 'arg))
 684                       (not (is-a? arg <generic>)))
 685                   (toplevel-define!
 686                    'arg
 687                    (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
 688          ((#:accessor)
 689           #'(define-class-pre-definition (rest ...)
 690               out ...
 691               (if (or (not (defined? 'arg))
 692                       (not (is-a? arg <accessor>)))
 693                   (toplevel-define!
 694                    'arg
 695                    (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
 696          (else
 697           #'(define-class-pre-definition (rest ...) out ...))))
 698       ((_ () out ...)
 699        #'(begin out ...)))))
 700
 701 ;; Some slot options require extra definitions to be made. In
 702 ;; particular, we want to make sure that the generic function objects
 703 ;; which represent accessors exist before `make-class' tries to add
 704 ;; methods to them.
 705 (define-syntax define-class-pre-definitions
 706   (lambda (x)
 707     (syntax-case x ()
 708       ((_ () out ...)
 709        #'(begin out ...))
 710       ((_ (slot rest ...) out ...)
 711        (keyword? (syntax->datum #'slot))
 712        #'(begin out ...))
 713       ((_ (slot rest ...) out ...)
 714        (identifier? #'slot)
 715        #'(define-class-pre-definitions (rest ...)
 716          out ...))
 717       ((_ ((slotname slotopt ...) rest ...) out ...)
 718        #'(define-class-pre-definitions (rest ...)
 719          out ... (define-class-pre-definition (slotopt ...)))))))
 720
 721 (define-syntax-rule (define-class name supers slot ...)
 722   (begin
 723     (define-class-pre-definitions (slot ...))
 724     (if (and (defined? 'name)
 725              (is-a? name <class>)
 726              (memq <object> (class-precedence-list name)))
 727         (class-redefinition name
 728                             (class supers slot ... #:name 'name))
 729         (toplevel-define! 'name (class supers slot ... #:name 'name)))))
 730
 731 (define-syntax-rule (standard-define-class arg ...)
 732   (define-class arg ...))
 733
 734 ;;;
 735 ;;; {Generic functions and accessors}
 736 ;;;
 737
 738 ;; Apparently the desired semantics are that we extend previous
 739 ;; procedural definitions, but that if `name' was already a generic, we
 740 ;; overwrite its definition.
 741 (define-macro (define-generic name)
 742   (if (not (symbol? name))
 743       (goops-error "bad generic function name: ~S" name))
 744   `(define ,name
 745      (if (and (defined? ',name) (is-a? ,name <generic>))
 746          (make <generic> #:name ',name)
 747          (ensure-generic (if (defined? ',name) ,name #f) ',name))))
 748
 749 (define-macro (define-extended-generic name val)
 750   (if (not (symbol? name))
 751       (goops-error "bad generic function name: ~S" name))
 752   `(define ,name (make-extended-generic ,val ',name)))
 753
 754 (define-macro (define-extended-generics names . args)
 755   (let ((prefixes (get-keyword #:prefix args #f)))
 756     (if prefixes
 757         `(begin
 758            ,@(map (lambda (name)
 759                     `(define-extended-generic ,name
 760                        (list ,@(map (lambda (prefix)
 761                                       (symbol-append prefix name))
 762                                     prefixes))))
 763                   names))
 764         (goops-error "no prefixes supplied"))))
 765
 766 (define* (make-generic #:optional name)
 767   (make <generic> #:name name))
 768
 769 (define* (make-extended-generic gfs #:optional name)
 770   (let* ((gfs (if (list? gfs) gfs (list gfs)))
 771          (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
 772     (let ((ans (if gws?
 773                    (let* ((sname (and name (make-setter-name name)))
 774                           (setters
 775                            (append-map (lambda (gf)
 776                                          (if (is-a? gf <generic-with-setter>)
 777                                              (list (ensure-generic (setter gf)
 778                                                                    sname))
 779                                              '()))
 780                                        gfs))
 781                           (es (make <extended-generic-with-setter>
 782                                 #:name name
 783                                 #:extends gfs
 784                                 #:setter (make <extended-generic>
 785                                            #:name sname
 786                                            #:extends setters))))
 787                      (extended-by! setters (setter es))
 788                      es)
 789                    (make <extended-generic>
 790                      #:name name
 791                      #:extends gfs))))
 792       (extended-by! gfs ans)
 793       ans)))
 794
 795 (define (extended-by! gfs eg)
 796   (for-each (lambda (gf)
 797               (slot-set! gf 'extended-by
 798                          (cons eg (slot-ref gf 'extended-by))))
 799             gfs)
 800   (invalidate-method-cache! eg))
 801
 802 (define (not-extended-by! gfs eg)
 803   (for-each (lambda (gf)
 804               (slot-set! gf 'extended-by
 805                          (delq! eg (slot-ref gf 'extended-by))))
 806             gfs)
 807   (invalidate-method-cache! eg))
 808
 809 (define* (ensure-generic old-definition #:optional name)
 810   (cond ((is-a? old-definition <generic>) old-definition)
 811         ((procedure-with-setter? old-definition)
 812          (make <generic-with-setter>
 813            #:name name
 814            #:default (procedure old-definition)
 815            #:setter (setter old-definition)))
 816         ((procedure? old-definition)
 817          (if (generic-capability? old-definition) old-definition
 818              (make <generic> #:name name #:default old-definition)))
 819         (else (make <generic> #:name name))))
 820
 821 ;; same semantics as <generic>
 822 (define-syntax-rule (define-accessor name)
 823   (define name
 824     (cond ((not (defined? 'name))  (ensure-accessor #f 'name))
 825           ((is-a? name <accessor>) (make <accessor> #:name 'name))
 826           (else                    (ensure-accessor name 'name)))))
 827
 828 (define (make-setter-name name)
 829   (string->symbol (string-append "setter:" (symbol->string name))))
 830
 831 (define* (make-accessor #:optional name)
 832   (make <accessor>
 833     #:name name
 834     #:setter (make <generic>
 835                #:name (and name (make-setter-name name)))))
 836
 837 (define* (ensure-accessor proc #:optional name)
 838   (cond ((and (is-a? proc <accessor>)
 839               (is-a? (setter proc) <generic>))
 840          proc)
 841         ((is-a? proc <generic-with-setter>)
 842          (upgrade-accessor proc (setter proc)))
 843         ((is-a? proc <generic>)
 844          (upgrade-accessor proc (make-generic name)))
 845         ((procedure-with-setter? proc)
 846          (make <accessor>
 847            #:name name
 848            #:default (procedure proc)
 849            #:setter (ensure-generic (setter proc) name)))
 850         ((procedure? proc)
 851          (ensure-accessor (if (generic-capability? proc)
 852                               (make <generic> #:name name #:default proc)
 853                               (ensure-generic proc name))
 854                           name))
 855         (else
 856          (make-accessor name))))
 857
 858 (define (upgrade-accessor generic setter)
 859   (let ((methods (slot-ref generic 'methods))
 860         (gws (make (if (is-a? generic <extended-generic>)
 861                        <extended-generic-with-setter>
 862                        <accessor>)
 863                    #:name (generic-function-name generic)
 864                    #:extended-by (slot-ref generic 'extended-by)
 865                    #:setter setter)))
 866     (if (is-a? generic <extended-generic>)
 867         (let ((gfs (slot-ref generic 'extends)))
 868           (not-extended-by! gfs generic)
 869           (slot-set! gws 'extends gfs)
 870           (extended-by! gfs gws)))
 871     ;; Steal old methods
 872     (for-each (lambda (method)
 873                 (slot-set! method 'generic-function gws))
 874               methods)
 875     (slot-set! gws 'methods methods)
 876     (invalidate-method-cache! gws)
 877     gws))
 878
 879 ;;;
 880 ;;; {Methods}
 881 ;;;
 882
 883 ;; Note: `a' and `b' can have unequal lengths (i.e. one can be one
 884 ;; element longer than the other when we have a dotted parameter
 885 ;; list). For instance, with the call
 886 ;;
 887 ;;   (M 1)
 888 ;;
 889 ;; with
 890 ;;
 891 ;;   (define-method M (a . l) ....)
 892 ;;   (define-method M (a) ....)
 893 ;;
 894 ;; we consider that the second method is more specific.
 895 ;;
 896 ;; Precondition: `a' and `b' are methods and are applicable to `types'.
 897 (define (%method-more-specific? a b types)
 898   (let lp ((a-specializers (method-specializers a))
 899            (b-specializers (method-specializers b))
 900            (types types))
 901     (cond
 902      ;; (a) less specific than (a b ...) or (a . b)
 903      ((null? a-specializers) #t)
 904      ;; (a b ...) or (a . b) less specific than (a)
 905      ((null? b-specializers) #f)
 906      ;; (a . b) less specific than (a b ...)
 907      ((not (pair? a-specializers)) #f)
 908      ;; (a b ...) more specific than (a . b)
 909      ((not (pair? b-specializers)) #t)
 910      (else
 911       (let ((a-specializer (car a-specializers))
 912             (b-specializer (car b-specializers))
 913             (a-specializers (cdr a-specializers))
 914             (b-specializers (cdr b-specializers))
 915             (type (car types))
 916             (types (cdr types)))
 917         (if (eq? a-specializer b-specializer)
 918             (lp a-specializers b-specializers types)
 919             (let lp ((cpl (class-precedence-list type)))
 920               (let ((elt (car cpl)))
 921                 (cond
 922                  ((eq? a-specializer elt) #t)
 923                  ((eq? b-specializer elt) #f)
 924                  (else (lp (cdr cpl))))))))))))
 925
 926 (define (%sort-applicable-methods methods types)
 927   (sort methods (lambda (a b) (%method-more-specific? a b types))))
 928
 929 (define (%compute-applicable-methods gf args)
 930   (define (method-applicable? m types)
 931     (let lp ((specs (method-specializers m)) (types types))
 932       (cond
 933        ((null? specs) (null? types))
 934        ((not (pair? specs)) #t)
 935        ((null? types) #f)
 936        (else
 937         (and (memq (car specs) (class-precedence-list (car types)))
 938              (lp (cdr specs) (cdr types)))))))
 939   (let ((n (length args))
 940         (types (map class-of args)))
 941     (let lp ((methods (generic-function-methods gf))
 942              (applicable '()))
 943       (if (null? methods)
 944           (and (not (null? applicable))
 945                (%sort-applicable-methods applicable types))
 946           (let ((m (car methods)))
 947             (lp (cdr methods)
 948                 (if (method-applicable? m types)
 949                     (cons m applicable)
 950                     applicable)))))))
 951
 952 (define compute-applicable-methods %compute-applicable-methods)
 953
 954 (define (toplevel-define! name val)
 955   (module-define! (current-module) name val))
 956
 957 (define-syntax define-method
 958   (syntax-rules (setter)
 959     ((_ ((setter name) . args) body ...)
 960      (begin
 961        (if (or (not (defined? 'name))
 962                (not (is-a? name <accessor>)))
 963            (toplevel-define! 'name
 964                              (ensure-accessor
 965                               (if (defined? 'name) name #f) 'name)))
 966        (add-method! (setter name) (method args body ...))))
 967     ((_ (name . args) body ...)
 968      (begin
 969        ;; FIXME: this code is how it always was, but it's quite cracky:
 970        ;; it will only define the generic function if it was undefined
 971        ;; before (ok), or *was defined to #f*. The latter is crack. But
 972        ;; there are bootstrap issues about fixing this -- change it to
 973        ;; (is-a? name <generic>) and see.
 974        (if (or (not (defined? 'name))
 975                (not name))
 976            (toplevel-define! 'name (make <generic> #:name 'name)))
 977        (add-method! name (method args body ...))))))
 978
 979 (define-syntax method
 980   (lambda (x)
 981     (define (parse-args args)
 982       (let lp ((ls args) (formals '()) (specializers '()))
 983         (syntax-case ls ()
 984           (((f s) . rest)
 985            (and (identifier? #'f) (identifier? #'s))
 986            (lp #'rest
 987                (cons #'f formals)
 988                (cons #'s specializers)))
 989           ((f . rest)
 990            (identifier? #'f)
 991            (lp #'rest
 992                (cons #'f formals)
 993                (cons #'<top> specializers)))
 994           (()
 995            (list (reverse formals)
 996                  (reverse (cons #''() specializers))))
 997           (tail
 998            (identifier? #'tail)
 999            (list (append (reverse formals) #'tail)
1000                  (reverse (cons #'<top> specializers)))))))
1001
1002     (define (find-free-id exp referent)
1003       (syntax-case exp ()
1004         ((x . y)
1005          (or (find-free-id #'x referent)
1006              (find-free-id #'y referent)))
1007         (x
1008          (identifier? #'x)
1009          (let ((id (datum->syntax #'x referent)))
1010            (and (free-identifier=? #'x id) id)))
1011         (_ #f)))
1012
1013     (define (compute-procedure formals body)
1014       (syntax-case body ()
1015         ((body0 ...)
1016          (with-syntax ((formals formals))
1017            #'(lambda formals body0 ...)))))
1018
1019     (define (->proper args)
1020       (let lp ((ls args) (out '()))
1021         (syntax-case ls ()
1022           ((x . xs)        (lp #'xs (cons #'x out)))
1023           (()              (reverse out))
1024           (tail            (reverse (cons #'tail out))))))
1025
1026     (define (compute-make-procedure formals body next-method)
1027       (syntax-case body ()
1028         ((body ...)
1029          (with-syntax ((next-method next-method))
1030            (syntax-case formals ()
1031              ((formal ...)
1032               #'(lambda (real-next-method)
1033                   (lambda (formal ...)
1034                     (let ((next-method (lambda args
1035                                          (if (null? args)
1036                                              (real-next-method formal ...)
1037                                              (apply real-next-method args)))))
1038                       body ...))))
1039              (formals
1040               (with-syntax (((formal ...) (->proper #'formals)))
1041                 #'(lambda (real-next-method)
1042                     (lambda formals
1043                       (let ((next-method (lambda args
1044                                            (if (null? args)
1045                                                (apply real-next-method formal ...)
1046                                                (apply real-next-method args)))))
1047                         body ...))))))))))
1048
1049     (define (compute-procedures formals body)
1050       ;; So, our use of this is broken, because it operates on the
1051       ;; pre-expansion source code. It's equivalent to just searching
1052       ;; for referent in the datums. Ah well.
1053       (let ((id (find-free-id body 'next-method)))
1054         (if id
1055             ;; return a make-procedure
1056             (values #'#f
1057                     (compute-make-procedure formals body id))
1058             (values (compute-procedure formals body)
1059                     #'#f))))
1060
1061     (syntax-case x ()
1062       ((_ args) #'(method args (if #f #f)))
1063       ((_ args body0 body1 ...)
1064        (with-syntax (((formals (specializer ...)) (parse-args #'args)))
1065          (call-with-values
1066              (lambda ()
1067                (compute-procedures #'formals #'(body0 body1 ...)))
1068            (lambda (procedure make-procedure)
1069              (with-syntax ((procedure procedure)
1070                            (make-procedure make-procedure))
1071                #'(make <method>
1072                    #:specializers (cons* specializer ...)
1073                    #:formals 'formals
1074                    #:body '(body0 body1 ...)
1075                    #:make-procedure make-procedure
1076                    #:procedure procedure)))))))))
1077
1078 ;;;
1079 ;;; {add-method!}
1080 ;;;
1081
1082 (define (add-method-in-classes! m)
1083   ;; Add method in all the classes which appears in its specializers list
1084   (for-each* (lambda (x)
1085                (let ((dm (class-direct-methods x)))
1086                  (if (not (memq m dm))
1087                      (slot-set! x 'direct-methods (cons m dm)))))
1088              (method-specializers m)))
1089
1090 (define (remove-method-in-classes! m)
1091   ;; Remove method in all the classes which appears in its specializers list
1092   (for-each* (lambda (x)
1093                (slot-set! x
1094                           'direct-methods
1095                           (delv! m (class-direct-methods x))))
1096              (method-specializers m)))
1097
1098 (define (compute-new-list-of-methods gf new)
1099   (let ((new-spec (method-specializers new))
1100         (methods  (slot-ref gf 'methods)))
1101     (let loop ((l methods))
1102       (if (null? l)
1103           (cons new methods)
1104           (if (equal? (method-specializers (car l)) new-spec)
1105               (begin
1106                 ;; This spec. list already exists. Remove old method from dependents
1107                 (remove-method-in-classes! (car l))
1108                 (set-car! l new)
1109                 methods)
1110               (loop (cdr l)))))))
1111
1112 (define (method-n-specializers m)
1113   (length* (slot-ref m 'specializers)))
1114
1115 (define (calculate-n-specialized gf)
1116   (fold (lambda (m n) (max n (method-n-specializers m)))
1117         0
1118         (generic-function-methods gf)))
1119
1120 (define (invalidate-method-cache! gf)
1121   (%invalidate-method-cache! gf)
1122   (slot-set! gf 'n-specialized (calculate-n-specialized gf))
1123   (for-each (lambda (gf) (invalidate-method-cache! gf))
1124             (slot-ref gf 'extended-by)))
1125
1126 (define internal-add-method!
1127   (method ((gf <generic>) (m <method>))
1128     (slot-set! m  'generic-function gf)
1129     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
1130     (invalidate-method-cache! gf)
1131     (add-method-in-classes! m)
1132     *unspecified*))
1133
1134 (define-generic add-method!)
1135
1136 ((method-procedure internal-add-method!) add-method! internal-add-method!)
1137
1138 (define-method (add-method! (proc <procedure>) (m <method>))
1139   (if (generic-capability? proc)
1140       (begin
1141         (enable-primitive-generic! proc)
1142         (add-method! proc m))
1143       (next-method)))
1144
1145 (define-method (add-method! (pg <primitive-generic>) (m <method>))
1146   (add-method! (primitive-generic-generic pg) m))
1147
1148 (define-method (add-method! obj (m <method>))
1149   (goops-error "~S is not a valid generic function" obj))
1150
1151 ;;;
1152 ;;; {Access to meta objects}
1153 ;;;
1154
1155 ;;;
1156 ;;; Methods
1157 ;;;
1158 (define-method (method-source (m <method>))
1159   (let* ((spec (map* class-name (slot-ref m 'specializers)))
1160          (src (procedure-source (slot-ref m 'procedure))))
1161     (and src
1162          (let ((args (cadr src))
1163                (body (cddr src)))
1164            (cons 'method
1165                  (cons (map* list args spec)
1166                        body))))))
1167
1168 (define-method (method-formals (m <method>))
1169   (slot-ref m 'formals))
1170
1171 ;;;
1172 ;;; Slots
1173 ;;;
1174 (define slot-definition-name car)
1175
1176 (define slot-definition-options cdr)
1177
1178 (define (slot-definition-allocation s)
1179   (get-keyword #:allocation (cdr s) #:instance))
1180
1181 (define (slot-definition-getter s)
1182   (get-keyword #:getter (cdr s) #f))
1183
1184 (define (slot-definition-setter s)
1185   (get-keyword #:setter (cdr s) #f))
1186
1187 (define (slot-definition-accessor s)
1188   (get-keyword #:accessor (cdr s) #f))
1189
1190 (define (slot-definition-init-value s)
1191   ;; can be #f, so we can't use #f as non-value
1192   (get-keyword #:init-value (cdr s) (make-unbound)))
1193
1194 (define (slot-definition-init-form s)
1195   (get-keyword #:init-form (cdr s) (make-unbound)))
1196
1197 (define (slot-definition-init-thunk s)
1198   (get-keyword #:init-thunk (cdr s) #f))
1199
1200 (define (slot-definition-init-keyword s)
1201   (get-keyword #:init-keyword (cdr s) #f))
1202
1203 (define (class-slot-definition class slot-name)
1204   (assq slot-name (class-slots class)))
1205
1206 (define (slot-init-function class slot-name)
1207   (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
1208
1209 (define (accessor-method-slot-definition obj)
1210   "Return the slot definition of the accessor @var{obj}."
1211   (slot-ref obj 'slot-definition))
1212
1213
1214 ;;;
1215 ;;; {Standard methods used by the C runtime}
1216 ;;;
1217
1218 ;;; Methods to compare objects
1219 ;;;
1220
1221 ;; Have to do this in a strange order because equal? is used in the
1222 ;; add-method! implementation; we need to make sure that when the
1223 ;; primitive is extended, that the generic has a method. =
1224 (define g-equal? (make-generic 'equal?))
1225 ;; When this generic gets called, we will have already checked eq? and
1226 ;; eqv? -- the purpose of this generic is to extend equality. So by
1227 ;; default, there is no extension, thus the #f return.
1228 (add-method! g-equal? (method (x y) #f))
1229 (set-primitive-generic! equal? g-equal?)
1230
1231 ;;;
1232 ;;; methods to display/write an object
1233 ;;;
1234
1235 ;     Code for writing objects must test that the slots they use are
1236 ;     bound. Otherwise a slot-unbound method will be called and will
1237 ;     conduct to an infinite loop.
1238
1239 ;; Write
1240 (define (display-address o file)
1241   (display (number->string (object-address o) 16) file))
1242
1243 (define-method (write o file)
1244   (display "#<instance " file)
1245   (display-address o file)
1246   (display #\> file))
1247
1248 (define write-object (primitive-generic-generic write))
1249
1250 (define-method (write (o <object>) file)
1251   (let ((class (class-of o)))
1252     (if (slot-bound? class 'name)
1253         (begin
1254           (display "#<" file)
1255           (display (class-name class) file)
1256           (display #\space file)
1257           (display-address o file)
1258           (display #\> file))
1259         (next-method))))
1260
1261 (define-method (write (class <class>) file)
1262   (let ((meta (class-of class)))
1263     (if (and (slot-bound? class 'name)
1264              (slot-bound? meta 'name))
1265         (begin
1266           (display "#<" file)
1267           (display (class-name meta) file)
1268           (display #\space file)
1269           (display (class-name class) file)
1270           (display #\space file)
1271           (display-address class file)
1272           (display #\> file))
1273         (next-method))))
1274
1275 (define-method (write (gf <generic>) file)
1276   (let ((meta (class-of gf)))
1277     (if (and (slot-bound? meta 'name)
1278              (slot-bound? gf 'methods))
1279         (begin
1280           (display "#<" file)
1281           (display (class-name meta) file)
1282           (let ((name (generic-function-name gf)))
1283             (if name
1284                 (begin
1285                   (display #\space file)
1286                   (display name file))))
1287           (display " (" file)
1288           (display (length (generic-function-methods gf)) file)
1289           (display ")>" file))
1290         (next-method))))
1291
1292 (define-method (write (o <method>) file)
1293   (let ((meta (class-of o)))
1294     (if (and (slot-bound? meta 'name)
1295              (slot-bound? o 'specializers))
1296         (begin
1297           (display "#<" file)
1298           (display (class-name meta) file)
1299           (display #\space file)
1300           (display (map* (lambda (spec)
1301                            (if (slot-bound? spec 'name)
1302                                (slot-ref spec 'name)
1303                                spec))
1304                          (method-specializers o))
1305                    file)
1306           (display #\space file)
1307           (display-address o file)
1308           (display #\> file))
1309         (next-method))))
1310
1311 ;; Display (do the same thing as write by default)
1312 (define-method (display o file)
1313   (write-object o file))
1314
1315 ;;;
1316 ;;; Handling of duplicate bindings in the module system
1317 ;;;
1318
1319 (define (find-subclass super name)
1320   (let lp ((classes (class-direct-subclasses super)))
1321     (cond
1322      ((null? classes)
1323       (error "class not found" name))
1324      ((and (slot-bound? (car classes) 'name)
1325            (eq? (class-name (car classes)) name))
1326       (car classes))
1327      (else
1328       (lp (cdr classes))))))
1329
1330 ;; A record type.
1331 (define <module> (find-subclass <top> '<module>))
1332
1333 (define-method (merge-generics (module <module>)
1334                                (name <symbol>)
1335                                (int1 <module>)
1336                                (val1 <top>)
1337                                (int2 <module>)
1338                                (val2 <top>)
1339                                (var <top>)
1340                                (val <top>))
1341   #f)
1342
1343 (define-method (merge-generics (module <module>)
1344                                (name <symbol>)
1345                                (int1 <module>)
1346                                (val1 <generic>)
1347                                (int2 <module>)
1348                                (val2 <generic>)
1349                                (var <top>)
1350                                (val <boolean>))
1351   (and (not (eq? val1 val2))
1352        (make-variable (make-extended-generic (list val2 val1) name))))
1353
1354 (define-method (merge-generics (module <module>)
1355                                (name <symbol>)
1356                                (int1 <module>)
1357                                (val1 <generic>)
1358                                (int2 <module>)
1359                                (val2 <generic>)
1360                                (var <top>)
1361                                (gf <extended-generic>))
1362   (and (not (memq val2 (slot-ref gf 'extends)))
1363        (begin
1364          (slot-set! gf
1365                     'extends
1366                     (cons val2 (delq! val2 (slot-ref gf 'extends))))
1367          (slot-set! val2
1368                     'extended-by
1369                     (cons gf (delq! gf (slot-ref val2 'extended-by))))
1370          (invalidate-method-cache! gf)
1371          var)))
1372
1373 (module-define! duplicate-handlers 'merge-generics merge-generics)
1374
1375 (define-method (merge-accessors (module <module>)
1376                                 (name <symbol>)
1377                                 (int1 <module>)
1378                                 (val1 <top>)
1379                                 (int2 <module>)
1380                                 (val2 <top>)
1381                                 (var <top>)
1382                                 (val <top>))
1383   #f)
1384
1385 (define-method (merge-accessors (module <module>)
1386                                 (name <symbol>)
1387                                 (int1 <module>)
1388                                 (val1 <accessor>)
1389                                 (int2 <module>)
1390                                 (val2 <accessor>)
1391                                 (var <top>)
1392                                 (val <top>))
1393   (merge-generics module name int1 val1 int2 val2 var val))
1394
1395 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
1396
1397 ;;;
1398 ;;; slot access
1399 ;;;
1400
1401 (define (class-slot-g-n-s class slot-name)
1402   (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
1403          (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
1404                           (slot-missing class slot-name)))))
1405     (if (not (memq (slot-definition-allocation this-slot)
1406                    '(#:class #:each-subclass)))
1407         (slot-missing class slot-name))
1408     g-n-s))
1409
1410 (define (class-slot-ref class slot)
1411   (let ((x ((car (class-slot-g-n-s class slot)) #f)))
1412     (if (unbound? x)
1413         (slot-unbound class slot)
1414         x)))
1415
1416 (define (class-slot-set! class slot value)
1417   ((cadr (class-slot-g-n-s class slot)) #f value))
1418
1419 (define-method (slot-unbound (c <class>) (o <object>) s)
1420   (goops-error "Slot `~S' is unbound in object ~S" s o))
1421
1422 (define-method (slot-unbound (c <class>) s)
1423   (goops-error "Slot `~S' is unbound in class ~S" s c))
1424
1425 (define-method (slot-unbound (o <object>))
1426   (goops-error "Unbound slot in object ~S" o))
1427
1428 (define-method (slot-missing (c <class>) (o <object>) s)
1429   (goops-error "No slot with name `~S' in object ~S" s o))
1430
1431 (define-method (slot-missing (c <class>) s)
1432   (goops-error "No class slot with name `~S' in class ~S" s c))
1433
1434
1435 (define-method (slot-missing (c <class>) (o <object>) s value)
1436   (slot-missing c o s))
1437
1438 ;;; Methods for the possible error we can encounter when calling a gf
1439
1440 (define-method (no-next-method (gf <generic>) args)
1441   (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
1442
1443 (define-method (no-applicable-method (gf <generic>) args)
1444   (goops-error "No applicable method for ~S in call ~S"
1445                gf (cons (generic-function-name gf) args)))
1446
1447 (define-method (no-method (gf <generic>) args)
1448   (goops-error "No method defined for ~S"  gf))
1449
1450 ;;;
1451 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
1452 ;;;
1453
1454 (define-method (shallow-clone (self <object>))
1455   (let ((clone (%allocate-instance (class-of self) '()))
1456         (slots (map slot-definition-name
1457                     (class-slots (class-of self)))))
1458     (for-each (lambda (slot)
1459                 (if (slot-bound? self slot)
1460                     (slot-set! clone slot (slot-ref self slot))))
1461               slots)
1462     clone))
1463
1464 (define-method (deep-clone  (self <object>))
1465   (let ((clone (%allocate-instance (class-of self) '()))
1466         (slots (map slot-definition-name
1467                     (class-slots (class-of self)))))
1468     (for-each (lambda (slot)
1469                 (if (slot-bound? self slot)
1470                     (slot-set! clone slot
1471                                (let ((value (slot-ref self slot)))
1472                                  (if (instance? value)
1473                                      (deep-clone value)
1474                                      value)))))
1475               slots)
1476     clone))
1477
1478 ;;;
1479 ;;; {Class redefinition utilities}
1480 ;;;
1481
1482 ;;; (class-redefinition OLD NEW)
1483 ;;;
1484
1485 ;;; Has correct the following conditions:
1486
1487 ;;; Methods
1488 ;;;
1489 ;;; 1. New accessor specializers refer to new header
1490 ;;;
1491 ;;; Classes
1492 ;;;
1493 ;;; 1. New class cpl refers to the new class header
1494 ;;; 2. Old class header exists on old super classes direct-subclass lists
1495 ;;; 3. New class header exists on new super classes direct-subclass lists
1496
1497 (define-method (class-redefinition (old <class>) (new <class>))
1498   ;; Work on direct methods:
1499   ;;            1. Remove accessor methods from the old class
1500   ;;            2. Patch the occurences of new in the specializers by old
1501   ;;            3. Displace the methods from old to new
1502   (remove-class-accessors! old)                                 ;; -1-
1503   (let ((methods (class-direct-methods new)))
1504     (for-each (lambda (m)
1505                  (update-direct-method! m new old))     ;; -2-
1506               methods)
1507     (slot-set! new
1508                'direct-methods
1509                (append methods (class-direct-methods old))))
1510
1511   ;; Substitute old for new in new cpl
1512   (set-car! (slot-ref new 'cpl) old)
1513
1514   ;; Remove the old class from the direct-subclasses list of its super classes
1515   (for-each (lambda (c) (slot-set! c 'direct-subclasses
1516                                    (delv! old (class-direct-subclasses c))))
1517             (class-direct-supers old))
1518
1519   ;; Replace the new class with the old in the direct-subclasses of the supers
1520   (for-each (lambda (c)
1521               (slot-set! c 'direct-subclasses
1522                          (cons old (delv! new (class-direct-subclasses c)))))
1523             (class-direct-supers new))
1524
1525   ;; Swap object headers
1526   (%modify-class old new)
1527
1528   ;; Now old is NEW!
1529
1530   ;; Redefine all the subclasses of old to take into account modification
1531   (for-each
1532        (lambda (c)
1533          (update-direct-subclass! c new old))
1534        (class-direct-subclasses new))
1535
1536   ;; Invalidate class so that subsequent instances slot accesses invoke
1537   ;; change-object-class
1538   (slot-set! new 'redefined old)
1539   (%invalidate-class new) ;must come after slot-set!
1540
1541   old)
1542
1543 ;;;
1544 ;;; remove-class-accessors!
1545 ;;;
1546
1547 (define-method (remove-class-accessors! (c <class>))
1548   (for-each (lambda (m)
1549               (if (is-a? m <accessor-method>)
1550                   (let ((gf (slot-ref m 'generic-function)))
1551                     ;; remove the method from its GF
1552                     (slot-set! gf 'methods
1553                                (delq1! m (slot-ref gf 'methods)))
1554                     (invalidate-method-cache! gf)
1555                     ;; remove the method from its specializers
1556                     (remove-method-in-classes! m))))
1557             (class-direct-methods c)))
1558
1559 ;;;
1560 ;;; update-direct-method!
1561 ;;;
1562
1563 (define-method (update-direct-method! (m  <method>)
1564                                       (old <class>)
1565                                       (new <class>))
1566   (let loop ((l (method-specializers m)))
1567     ;; Note: the <top> in dotted list is never used.
1568     ;; So we can work as if we had only proper lists.
1569     (if (pair? l)
1570         (begin
1571           (if (eqv? (car l) old)
1572               (set-car! l new))
1573           (loop (cdr l))))))
1574
1575 ;;;
1576 ;;; update-direct-subclass!
1577 ;;;
1578
1579 (define-method (update-direct-subclass! (c <class>)
1580                                         (old <class>)
1581                                         (new <class>))
1582   (class-redefinition c
1583                       (make-class (class-direct-supers c)
1584                                   (class-direct-slots c)
1585                                   #:name (class-name c)
1586                                   #:metaclass (class-of c))))
1587
1588 ;;;
1589 ;;; {Utilities for INITIALIZE methods}
1590 ;;;
1591
1592 ;;; compute-slot-accessors
1593 ;;;
1594 (define (compute-slot-accessors class slots)
1595   (for-each
1596       (lambda (s g-n-s)
1597         (let ((getter-function (slot-definition-getter   s))
1598               (setter-function (slot-definition-setter   s))
1599               (accessor        (slot-definition-accessor s)))
1600           (if getter-function
1601               (add-method! getter-function
1602                            (compute-getter-method class g-n-s)))
1603           (if setter-function
1604               (add-method! setter-function
1605                            (compute-setter-method class g-n-s)))
1606           (if accessor
1607               (begin
1608                 (add-method! accessor
1609                              (compute-getter-method class g-n-s))
1610                 (add-method! (setter accessor)
1611                              (compute-setter-method class g-n-s))))))
1612       slots (slot-ref class 'getters-n-setters)))
1613
1614 (define-method (compute-getter-method (class <class>) slotdef)
1615   (let ((init-thunk (cadr slotdef))
1616         (g-n-s (cddr slotdef)))
1617     (make <accessor-method>
1618           #:specializers (list class)
1619           #:procedure (cond ((pair? g-n-s)
1620                              (make-generic-bound-check-getter (car g-n-s)))
1621                             (init-thunk
1622                              (standard-get g-n-s))
1623                             (else
1624                              (bound-check-get g-n-s)))
1625           #:slot-definition slotdef)))
1626
1627 (define-method (compute-setter-method (class <class>) slotdef)
1628   (let ((g-n-s (cddr slotdef)))
1629     (make <accessor-method>
1630           #:specializers (list class <top>)
1631           #:procedure (if (pair? g-n-s)
1632                           (cadr g-n-s)
1633                           (standard-set g-n-s))
1634           #:slot-definition slotdef)))
1635
1636 (define (make-generic-bound-check-getter proc)
1637   (lambda (o) (assert-bound (proc o) o)))
1638
1639 ;;; Pre-generate getters and setters for the first 20 slots.
1640 (define-syntax define-standard-accessor-method
1641   (lambda (stx)
1642     (define num-standard-pre-cache 20)
1643     (syntax-case stx ()
1644       ((_ ((proc n) arg ...) body)
1645        #`(define proc
1646            (let ((cache (vector #,@(map (lambda (n*)
1647                                           #`(lambda (arg ...)
1648                                               (let ((n #,n*))
1649                                                 body)))
1650                                         (iota num-standard-pre-cache)))))
1651              (lambda (n)
1652                (if (< n #,num-standard-pre-cache)
1653                    (vector-ref cache n)
1654                    (lambda (arg ...) body)))))))))
1655
1656 (define-standard-accessor-method ((bound-check-get n) o)
1657   (let ((x (struct-ref o n)))
1658     (if (unbound? x)
1659         (slot-unbound o)
1660         x)))
1661
1662 (define-standard-accessor-method ((standard-get n) o)
1663   (struct-ref o n))
1664
1665 (define-standard-accessor-method ((standard-set n) o v)
1666   (struct-set! o n v))
1667
1668 ;;; compute-getters-n-setters
1669 ;;;
1670 (define (compute-getters-n-setters class slots)
1671
1672   (define (compute-slot-init-function name s)
1673     (or (let ((thunk (slot-definition-init-thunk s)))
1674           (and thunk
1675                (if (thunk? thunk)
1676                    thunk
1677                    (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
1678                                 name class thunk))))
1679         (let ((init (slot-definition-init-value s)))
1680           (and (not (unbound? init))
1681                (lambda () init)))))
1682
1683   (define (verify-accessors slot l)
1684     (cond ((integer? l))
1685           ((not (and (list? l) (= (length l) 2)))
1686            (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
1687                         slot class l))
1688           (else
1689            (let ((get (car l))
1690                  (set (cadr l)))
1691              (if (not (procedure? get))
1692                  (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1693                               slot class get))
1694              (if (not (procedure? set))
1695                  (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1696                               slot class set))))))
1697
1698   (map (lambda (s)
1699          ;; The strange treatment of nfields is due to backward compatibility.
1700          (let* ((index (slot-ref class 'nfields))
1701                 (g-n-s (compute-get-n-set class s))
1702                 (size (- (slot-ref class 'nfields) index))
1703                 (name  (slot-definition-name s)))
1704            ;; NOTE: The following is interdependent with C macros
1705            ;; defined above goops.c:scm_sys_prep_layout_x.
1706            ;;
1707            ;; For simple instance slots, we have the simplest form
1708            ;; '(name init-function . index)
1709            ;; For other slots we have
1710            ;; '(name init-function getter setter . alloc)
1711            ;; where alloc is:
1712            ;;   '(index size) for instance allocated slots
1713            ;;   '() for other slots
1714            (verify-accessors name g-n-s)
1715            (case (slot-definition-allocation s)
1716              ((#:each-subclass #:class)
1717               (unless (and (zero? size) (pair? g-n-s))
1718                 (error "Class-allocated slots should not reserve fields"))
1719               ;; Don't initialize the slot; that's handled when the slot
1720               ;; is allocated, in compute-get-n-set.
1721               (cons name (cons #f g-n-s)))
1722              (else
1723               (cons name
1724                     (cons (compute-slot-init-function name s)
1725                           (if (or (integer? g-n-s)
1726                                   (zero? size))
1727                               g-n-s
1728                               (append g-n-s (list index size)))))))))
1729        slots))
1730
1731 ;;; compute-cpl
1732 ;;;
1733
1734 ;; Replace the bootstrap compute-cpl with this definition.
1735 (define compute-cpl
1736   (make <generic> #:name 'compute-cpl))
1737
1738 (define-method (compute-cpl (class <class>))
1739   (compute-std-cpl class class-direct-supers))
1740
1741 ;;; compute-get-n-set
1742 ;;;
1743 (define-method (compute-get-n-set (class <class>) s)
1744   (define (class-slot-init-value)
1745     (let ((thunk (slot-definition-init-thunk s)))
1746       (if thunk
1747           (thunk)
1748           (slot-definition-init-value s))))
1749
1750   (case (slot-definition-allocation s)
1751     ((#:instance) ;; Instance slot
1752      ;; get-n-set is just its offset
1753      (let ((already-allocated (slot-ref class 'nfields)))
1754        (slot-set! class 'nfields (+ already-allocated 1))
1755        already-allocated))
1756
1757     ((#:class)  ;; Class slot
1758      ;; Class-slots accessors are implemented as 2 closures around
1759      ;; a Scheme variable. As instance slots, class slots must be
1760      ;; unbound at init time.
1761      (let ((name (slot-definition-name s)))
1762        (if (memq name (map slot-definition-name (class-direct-slots class)))
1763            ;; This slot is direct; create a new shared variable
1764            (make-closure-variable class (class-slot-init-value))
1765            ;; Slot is inherited. Find its definition in superclass
1766            (let loop ((l (cdr (class-precedence-list class))))
1767              (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1768                (if r
1769                    (cddr r)
1770                    (loop (cdr l))))))))
1771
1772     ((#:each-subclass) ;; slot shared by instances of direct subclass.
1773      ;; (Thomas Buerger, April 1998)
1774      (make-closure-variable class (class-slot-init-value)))
1775
1776     ((#:virtual) ;; No allocation
1777      ;; slot-ref and slot-set! function must be given by the user
1778      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
1779            (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
1780        (if (not (and get set))
1781            (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
1782                         s))
1783        (list get set)))
1784     (else    (next-method))))
1785
1786 (define (make-closure-variable class value)
1787   (list (lambda (o) value)
1788         (lambda (o v) (set! value v))))
1789
1790 (define-method (compute-get-n-set (o <object>) s)
1791   (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1792
1793 (define-method (compute-slots (class <class>))
1794   (build-slots-list (class-direct-slots class)
1795                     (class-precedence-list class)))
1796
1797 ;;;
1798 ;;; {Initialize}
1799 ;;;
1800
1801 (define-method (initialize (object <object>) initargs)
1802   (%initialize-object object initargs))
1803
1804 (define-method (initialize (class <class>) initargs)
1805   (next-method)
1806   (let ((dslots (get-keyword #:slots initargs '()))
1807         (supers (get-keyword #:dsupers    initargs '())))
1808     (slot-set! class 'name              (get-keyword #:name initargs '???))
1809     (slot-set! class 'direct-supers     supers)
1810     (slot-set! class 'direct-slots      dslots)
1811     (slot-set! class 'direct-subclasses '())
1812     (slot-set! class 'direct-methods    '())
1813     (slot-set! class 'cpl               (compute-cpl class))
1814     (slot-set! class 'redefined         #f)
1815     (let ((slots (compute-slots class)))
1816       (slot-set! class 'slots             slots)
1817       (slot-set! class 'nfields           0)
1818       (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1819                                                                      slots))
1820       ;; Build getters - setters - accessors
1821       (compute-slot-accessors class slots))
1822
1823     ;; Update the "direct-subclasses" of each inherited classes
1824     (for-each (lambda (x)
1825                 (slot-set! x
1826                            'direct-subclasses
1827                            (cons class (slot-ref x 'direct-subclasses))))
1828               supers)
1829
1830     ;; Support for the underlying structs:
1831
1832     ;; Set the layout slot
1833     (%prep-layout! class)
1834     ;; Inherit class flags (invisible on scheme level) from supers
1835     (%inherit-magic! class supers)))
1836
1837 (define (initialize-object-procedure object initargs)
1838   (let ((proc (get-keyword #:procedure initargs #f)))
1839     (cond ((not proc))
1840           ((pair? proc)
1841            (apply slot-set! object 'procedure proc))
1842           (else
1843            (slot-set! object 'procedure proc)))))
1844
1845 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
1846   (next-method)
1847   (initialize-object-procedure applicable-struct initargs))
1848
1849 (define-method (initialize (generic <generic>) initargs)
1850   (let ((previous-definition (get-keyword #:default initargs #f))
1851         (name (get-keyword #:name initargs #f)))
1852     (next-method)
1853     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1854                                     (list (method args
1855                                             (apply previous-definition args)))
1856                                     '()))
1857     (if name
1858         (set-procedure-property! generic 'name name))
1859     ))
1860
1861 (define-method (initialize (gws <generic-with-setter>) initargs)
1862   (next-method)
1863   (%set-object-setter! gws (get-keyword #:setter initargs #f)))
1864
1865 (define-method (initialize (eg <extended-generic>) initargs)
1866   (next-method)
1867   (slot-set! eg 'extends (get-keyword #:extends initargs '())))
1868
1869 (define dummy-procedure (lambda args *unspecified*))
1870
1871 (define-method (initialize (method <method>) initargs)
1872   (next-method)
1873   (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1874   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1875   (slot-set! method 'procedure
1876              (get-keyword #:procedure initargs #f))
1877   (slot-set! method 'formals (get-keyword #:formals initargs '()))
1878   (slot-set! method 'body (get-keyword #:body initargs '()))
1879   (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs #f)))
1880
1881
1882 ;;;
1883 ;;; {Change-class}
1884 ;;;
1885
1886 (define (change-object-class old-instance old-class new-class)
1887   (let ((new-instance (allocate-instance new-class '())))
1888     ;; Initialize the slots of the new instance
1889     (for-each (lambda (slot)
1890                 (if (and (slot-exists-using-class? old-class old-instance slot)
1891                          (eq? (slot-definition-allocation
1892                                (class-slot-definition old-class slot))
1893                               #:instance)
1894                          (slot-bound-using-class? old-class old-instance slot))
1895                     ;; Slot was present and allocated in old instance; copy it
1896                     (slot-set-using-class!
1897                      new-class
1898                      new-instance
1899                      slot
1900                      (slot-ref-using-class old-class old-instance slot))
1901                     ;; slot was absent; initialize it with its default value
1902                     (let ((init (slot-init-function new-class slot)))
1903                       (if init
1904                           (slot-set-using-class!
1905                                new-class
1906                                new-instance
1907                                slot
1908                                (apply init '()))))))
1909               (map slot-definition-name (class-slots new-class)))
1910     ;; Exchange old and new instance in place to keep pointers valid
1911     (%modify-instance old-instance new-instance)
1912     ;; Allow class specific updates of instances (which now are swapped)
1913     (update-instance-for-different-class new-instance old-instance)
1914     old-instance))
1915
1916
1917 (define-method (update-instance-for-different-class (old-instance <object>)
1918                                                     (new-instance
1919                                                      <object>))
1920   ;;not really important what we do, we just need a default method
1921   new-instance)
1922
1923 (define-method (change-class (old-instance <object>) (new-class <class>))
1924   (change-object-class old-instance (class-of old-instance) new-class))
1925
1926 ;;;
1927 ;;; {make}
1928 ;;;
1929 ;;; A new definition which overwrites the previous one which was built-in
1930 ;;;
1931
1932 (define-method (allocate-instance (class <class>) initargs)
1933   (%allocate-instance class initargs))
1934
1935 (define-method (make-instance (class <class>) . initargs)
1936   (let ((instance (allocate-instance class initargs)))
1937     (initialize instance initargs)
1938     instance))
1939
1940 (define make make-instance)
1941
1942 ;;;
1943 ;;; {apply-generic}
1944 ;;;
1945 ;;; Protocol for calling standard generic functions.  This protocol is
1946 ;;; not used for real <generic> functions (in this case we use a
1947 ;;; completely C hard-coded protocol).  Apply-generic is used by
1948 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1949 ;;; The code below is similar to the first MOP described in AMOP. In
1950 ;;; particular, it doesn't used the currified approach to gf
1951 ;;; call. There are 2 reasons for that:
1952 ;;;   - the protocol below is exposed to mimic completely the one written in C
1953 ;;;   - the currified protocol would be imho inefficient in C.
1954 ;;;
1955
1956 (define-method (apply-generic (gf <generic>) args)
1957   (if (null? (slot-ref gf 'methods))
1958       (no-method gf args))
1959   (let ((methods (compute-applicable-methods gf args)))
1960     (if methods
1961         (apply-methods gf (sort-applicable-methods gf methods args) args)
1962         (no-applicable-method gf args))))
1963
1964 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1965 ;; *fixme* use let
1966 (define %%compute-applicable-methods
1967   (make <generic> #:name 'compute-applicable-methods))
1968
1969 (define-method (%%compute-applicable-methods (gf <generic>) args)
1970   (%compute-applicable-methods gf args))
1971
1972 (set! compute-applicable-methods %%compute-applicable-methods)
1973
1974 (define-method (sort-applicable-methods (gf <generic>) methods args)
1975   (%sort-applicable-methods methods (map class-of args)))
1976
1977 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1978   (%method-more-specific? m1 m2 targs))
1979
1980 (define-method (apply-method (gf <generic>) methods build-next args)
1981   (apply (method-procedure (car methods))
1982          (build-next (cdr methods) args)
1983          args))
1984
1985 (define-method (apply-methods (gf <generic>) (l <list>) args)
1986   (letrec ((next (lambda (procs args)
1987                    (lambda new-args
1988                      (let ((a (if (null? new-args) args new-args)))
1989                        (if (null? procs)
1990                            (no-next-method gf a)
1991                            (apply-method gf procs next a)))))))
1992     (apply-method gf l next args)))
1993
1994 ;; We don't want the following procedure to turn up in backtraces:
1995 (for-each (lambda (proc)
1996             (set-procedure-property! proc 'system-procedure #t))
1997           (list slot-unbound
1998                 slot-missing
1999                 no-next-method
2000                 no-applicable-method
2001                 no-method
2002                 ))
2003
2004 ;;;
2005 ;;; {<composite-metaclass> and <active-metaclass>}
2006 ;;;
2007
2008 ;(autoload "active-slot"    <active-metaclass>)
2009 ;(autoload "composite-slot" <composite-metaclass>)
2010 ;(export <composite-metaclass> <active-metaclass>)
2011
2012 ;;;
2013 ;;; {Tools}
2014 ;;;
2015
2016 ;; list2set
2017 ;;
2018 ;; duplicate the standard list->set function but using eq instead of
2019 ;; eqv which really sucks a lot, uselessly here
2020 ;;
2021 (define (list2set l)
2022   (let loop ((l l)
2023              (res '()))
2024     (cond
2025      ((null? l) res)
2026      ((memq (car l) res) (loop (cdr l) res))
2027      (else (loop (cdr l) (cons (car l) res))))))
2028
2029 (define (class-subclasses c)
2030   (letrec ((allsubs (lambda (c)
2031                       (cons c (mapappend allsubs
2032                                          (class-direct-subclasses c))))))
2033     (list2set (cdr (allsubs c)))))
2034
2035 (define (class-methods c)
2036   (list2set (mapappend class-direct-methods
2037                        (cons c (class-subclasses c)))))
2038
2039 ;;;
2040 ;;; {Final initialization}
2041 ;;;
2042
2043 ;; Tell C code that the main bulk of Goops has been loaded
2044 (%goops-loaded)
2045
2046
2047 \f
2048
2049 ;;;
2050 ;;; {SMOB and port classes}
2051 ;;;
2052
2053 (define <arbiter> (find-subclass <top> '<arbiter>))
2054 (define <promise> (find-subclass <top> '<promise>))
2055 (define <thread> (find-subclass <top> '<thread>))
2056 (define <mutex> (find-subclass <top> '<mutex>))
2057 (define <condition-variable> (find-subclass <top> '<condition-variable>))
2058 (define <regexp> (find-subclass <top> '<regexp>))
2059 (define <hook> (find-subclass <top> '<hook>))
2060 (define <bitvector> (find-subclass <top> '<bitvector>))
2061 (define <random-state> (find-subclass <top> '<random-state>))
2062 (define <async> (find-subclass <top> '<async>))
2063 (define <directory> (find-subclass <top> '<directory>))
2064 (define <array> (find-subclass <top> '<array>))
2065 (define <character-set> (find-subclass <top> '<character-set>))
2066 (define <dynamic-object> (find-subclass <top> '<dynamic-object>))
2067 (define <guardian> (find-subclass <applicable> '<guardian>))
2068 (define <macro> (find-subclass <top> '<macro>))
2069
2070 (define (define-class-subtree class)
2071   (define! (class-name class) class)
2072   (for-each define-class-subtree (class-direct-subclasses class)))
2073
2074 (define-class-subtree (find-subclass <port> '<file-port>))