module/oop/goops.scm

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