module/oop/goops.scm

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