module/oop/goops.scm

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