3
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc.
5
;;;; This library is free software; you can redistribute it and/or
6
;;;; modify it under the terms of the GNU Lesser General Public
7
;;;; License as published by the Free Software Foundation; either
8
;;;; version 2.1 of the License, or (at your option) any later version.
10
;;;; This library is distributed in the hope that it will be useful,
11
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13
;;;; Lesser General Public License for more details.
15
;;;; You should have received a copy of the GNU Lesser General Public
16
;;;; License along with this library; if not, write to the Free Software
17
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21
;;;; This software is a derivative work of other copyrighted softwares; the
22
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
24
;;;; This file is based upon stklos.stk from the STk distribution by
25
;;;; Erick Gallesio <eg@unice.fr>.
28
(define-module (oop goops)
29
:export-syntax (define-class class standard-define-class
30
define-generic define-accessor define-method
31
define-extended-generic define-extended-generics
33
:export (goops-version is-a? class-of
34
ensure-metaclass ensure-metaclass-with-supers
36
make-generic ensure-generic
38
make-accessor ensure-accessor
39
process-class-pre-define-generic
40
process-class-pre-define-accessor
41
process-define-generic
42
process-define-accessor
43
make-method add-method!
44
object-eqv? object-equal?
45
class-slot-ref class-slot-set! slot-unbound slot-missing
46
slot-definition-name slot-definition-options
47
slot-definition-allocation
48
slot-definition-getter slot-definition-setter
49
slot-definition-accessor
50
slot-definition-init-value slot-definition-init-form
51
slot-definition-init-thunk slot-definition-init-keyword
52
slot-init-function class-slot-definition
54
compute-cpl compute-std-cpl compute-get-n-set compute-slots
55
compute-getter-method compute-setter-method
56
allocate-instance initialize make-instance make
57
no-next-method no-applicable-method no-method
58
change-class update-instance-for-different-class
59
shallow-clone deep-clone
61
apply-generic apply-method apply-methods
62
compute-applicable-methods %compute-applicable-methods
63
method-more-specific? sort-applicable-methods
64
class-subclasses class-methods
67
;;; *fixme* Should go into goops.c
68
instance? slot-ref-using-class
69
slot-set-using-class! slot-bound-using-class?
70
slot-exists-using-class? slot-ref slot-set! slot-bound?
71
class-name class-direct-supers class-direct-subclasses
72
class-direct-methods class-direct-slots class-precedence-list
73
class-slots class-environment
75
generic-function-methods method-generic-function method-specializers
76
primitive-generic-generic enable-primitive-generic!
77
method-procedure accessor-method-slot-definition
78
slot-exists? make find-method get-keyword)
79
:replace (<class> <operator-class> <entity-class> <entity>)
82
;; First initialize the builtin part of GOOPS
83
(%init-goops-builtins)
85
;; Then load the rest of GOOPS
86
(use-modules (oop goops util)
91
(define min-fixnum (- (expt 2 29)))
93
(define max-fixnum (- (expt 2 29) 1))
98
(define (goops-error format-string . args)
100
(scm-error 'goops-error #f format-string args '()))
105
(define (is-a? obj class)
106
(and (memq class (class-precedence-list (class-of obj))) #t))
113
(define ensure-metaclass-with-supers
114
(let ((table-of-metas '()))
115
(lambda (meta-supers)
116
(let ((entry (assoc meta-supers table-of-metas)))
118
;; Found a previously created metaclass
120
;; Create a new meta-class which inherit from "meta-supers"
121
(let ((new (make <class> #:dsupers meta-supers
123
#:name (gensym "metaclass"))))
124
(set! table-of-metas (cons (cons meta-supers new) table-of-metas))
127
(define (ensure-metaclass supers env)
130
(let* ((all-metas (map (lambda (x) (class-of x)) supers))
131
(all-cpls (apply append
133
(cdr (class-precedence-list m)))
136
;; Find the most specific metaclasses. The new metaclass will be
137
;; a subclass of these.
140
(if (and (not (member meta all-cpls))
141
(not (member meta needed-metas)))
142
(set! needed-metas (append needed-metas (list meta)))))
144
;; Now return a subclass of the metaclasses we found.
145
(if (null? (cdr needed-metas))
146
(car needed-metas) ; If there's only one, just use it.
147
(ensure-metaclass-with-supers needed-metas)))))
153
;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
155
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
156
;;; OPTION ::= KEYWORD VALUE
158
(define (define-class-pre-definition keyword exp env)
161
`(process-class-pre-define-generic ',exp))
163
`(process-class-pre-define-accessor ',exp))
166
(define (process-class-pre-define-generic name)
167
(let ((var (module-variable (current-module) name)))
169
(variable-bound? var)
170
(is-a? (variable-ref var) <generic>)))
171
(process-define-generic name))))
173
(define (process-class-pre-define-accessor name)
174
(let ((var (module-variable (current-module) name)))
176
(not (variable-bound? var)))
177
(process-define-accessor name))
178
((or (is-a? (variable-ref var) <accessor>)
179
(is-a? (variable-ref var) <extended-generic-with-setter>)))
180
((is-a? (variable-ref var) <generic>)
181
;;*fixme* don't mutate an imported object!
182
(variable-set! var (ensure-accessor (variable-ref var) name)))
184
(process-define-accessor name)))))
186
;;; This code should be implemented in C.
189
(letrec (;; Some slot options require extra definitions to be made.
190
;; In particular, we want to make sure that the generic
191
;; function objects which represent accessors exist
192
;; before `make-class' tries to add methods to them.
194
;; Postpone error handling to class macro.
198
(do ((slots slots (cdr slots))
200
(if (pair? (car slots))
201
(do ((options (cdar slots) (cddr options))
202
(definitions definitions
203
(cond ((not (symbol? (cadr options)))
205
((define-class-pre-definition
209
=> (lambda (definition)
210
(cons definition definitions)))
211
(else definitions))))
212
((not (and (pair? options)
213
(pair? (cdr options))))
216
((or (not (pair? slots))
217
(keyword? (car slots)))
218
(reverse definitions)))))
224
(procedure->memoizing-macro
226
(cond ((not (top-level-env? env))
227
(goops-error "define-class: Only allowed at top level"))
228
((not (and (list? exp) (>= (length exp) 3)))
229
(goops-error "missing or extra expression"))
231
(let ((name (name exp)))
234
,@(pre-definitions (slots exp) env)
235
;; update the current-module
236
(let* ((class (class ,@(cddr exp) #:name ',name))
237
(var (module-ensure-local-variable!
238
(current-module) ',name))
239
(old (and (variable-bound? var)
240
(variable-ref var))))
243
(memq <object> (class-precedence-list old)))
244
(variable-set! var (class-redefinition old class))
245
(variable-set! var class)))))))))))
247
(define standard-define-class define-class)
249
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
251
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
252
;;; OPTION ::= KEYWORD VALUE
255
(letrec ((slot-option-keyword car)
256
(slot-option-value cadr)
257
(process-slot-options
259
(let loop ((options options)
261
(cond ((null? options)
263
((null? (cdr options))
264
(goops-error "malformed slot option list"))
265
((not (keyword? (slot-option-keyword options)))
266
(goops-error "malformed slot option list"))
268
(case (slot-option-keyword options)
271
(append (list `(lambda ()
272
,(slot-option-value options))
275
(slot-option-value options))
284
(procedure->memoizing-macro
289
(cond ((not (and (list? exp) (>= (length exp) 2)))
290
(goops-error "missing or extra expression"))
291
((not (list? (supers exp)))
292
(goops-error "malformed superclass list: ~S" (supers exp)))
294
(let ((slot-defs (cons #f '())))
295
(do ((slots (slots exp) (cdr slots))
296
(defs slot-defs (cdr defs)))
298
(keyword? (car slots)))
300
;; evaluate super class variables
301
(list ,@(supers exp))
302
;; evaluate slot definitions, except the slot name!
303
(list ,@(cdr slot-defs))
304
;; evaluate class options
306
;; place option last in case someone wants to
307
;; pass a different value
308
#:environment ',env))
311
(list (if (pair? (car slots))
312
`(list ',(slot-definition-name (car slots))
313
,@(process-slot-options
314
(slot-definition-options
316
`(list ',(car slots))))))))))))))
318
(define (make-class supers slots . options)
319
(let ((env (or (get-keyword #:environment options #f)
321
(let* ((name (get-keyword #:name options (make-unbound)))
322
(supers (if (not (or-map (lambda (class)
324
(class-precedence-list class)))
326
(append supers (list <object>))
328
(metaclass (or (get-keyword #:metaclass options #f)
329
(ensure-metaclass supers env))))
331
;; Verify that all direct slots are different and that we don't inherit
332
;; several time from the same class
333
(let ((tmp1 (find-duplicate supers))
334
(tmp2 (find-duplicate (map slot-definition-name slots))))
336
(goops-error "make-class: super class ~S is duplicate in class ~S"
339
(goops-error "make-class: slot ~S is duplicate in class ~S"
342
;; Everything seems correct, build the class
343
(apply make metaclass
351
;;; {Generic functions and accessors}
354
(define define-generic
355
(procedure->memoizing-macro
357
(let ((name (cadr exp)))
358
(cond ((not (symbol? name))
359
(goops-error "bad generic function name: ~S" name))
360
((top-level-env? env)
361
`(process-define-generic ',name))
363
`(define ,name (make <generic> #:name ',name))))))))
365
(define (process-define-generic name)
366
(let ((var (module-ensure-local-variable! (current-module) name)))
368
(not (variable-bound? var))
369
(is-a? (variable-ref var) <generic>))
370
;; redefine if NAME isn't defined previously, or is another generic
371
(variable-set! var (make <generic> #:name name))
372
;; otherwise try to upgrade the object to a generic
373
(variable-set! var (ensure-generic (variable-ref var) name)))))
375
(define define-extended-generic
376
(procedure->memoizing-macro
378
(let ((name (cadr exp)))
379
(cond ((not (symbol? name))
380
(goops-error "bad generic function name: ~S" name))
382
(goops-error "missing expression"))
384
`(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
385
(define define-extended-generics
386
(procedure->memoizing-macro
388
(let ((names (cadr exp))
389
(prefixes (get-keyword #:prefix (cddr exp) #f)))
392
,@(map (lambda (name)
393
`(define-extended-generic ,name
394
(list ,@(map (lambda (prefix)
395
(symbol-append prefix name))
398
(goops-error "no prefixes supplied"))))))
400
(define (make-generic . name)
401
(let ((name (and (pair? name) (car name))))
402
(make <generic> #:name name)))
404
(define (make-extended-generic gfs . name)
405
(let* ((name (and (pair? name) (car name)))
406
(gfs (if (pair? gfs) gfs (list gfs)))
407
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
409
(let* ((sname (and name (make-setter-name name)))
413
(if (is-a? gf <generic-with-setter>)
414
(list (ensure-generic (setter gf)
418
(es (make <extended-generic-with-setter>
421
#:setter (make <extended-generic>
423
#:extends setters))))
424
(extended-by! setters (setter es))
426
(make <extended-generic>
429
(extended-by! gfs ans)
432
(define (extended-by! gfs eg)
433
(for-each (lambda (gf)
434
(slot-set! gf 'extended-by
435
(cons eg (slot-ref gf 'extended-by))))
438
(define (not-extended-by! gfs eg)
439
(for-each (lambda (gf)
440
(slot-set! gf 'extended-by
441
(delq! eg (slot-ref gf 'extended-by))))
444
(define (ensure-generic old-definition . name)
445
(let ((name (and (pair? name) (car name))))
446
(cond ((is-a? old-definition <generic>) old-definition)
447
((procedure-with-setter? old-definition)
448
(make <generic-with-setter>
450
#:default (procedure old-definition)
451
#:setter (setter old-definition)))
452
((procedure? old-definition)
453
(make <generic> #:name name #:default old-definition))
454
(else (make <generic> #:name name)))))
456
(define define-accessor
457
(procedure->memoizing-macro
459
(let ((name (cadr exp)))
460
(cond ((not (symbol? name))
461
(goops-error "bad accessor name: ~S" name))
462
((top-level-env? env)
463
`(process-define-accessor ',name))
465
`(define ,name (make-accessor ',name))))))))
467
(define (process-define-accessor name)
468
(let ((var (module-ensure-local-variable! (current-module) name)))
470
(not (variable-bound? var))
471
(is-a? (variable-ref var) <accessor>)
472
(is-a? (variable-ref var) <extended-generic-with-setter>))
473
;; redefine if NAME isn't defined previously, or is another accessor
474
(variable-set! var (make-accessor name))
475
;; otherwise try to upgrade the object to an accessor
476
(variable-set! var (ensure-accessor (variable-ref var) name)))))
478
(define (make-setter-name name)
479
(string->symbol (string-append "setter:" (symbol->string name))))
481
(define (make-accessor . name)
482
(let ((name (and (pair? name) (car name))))
485
#:setter (make <generic>
486
#:name (and name (make-setter-name name))))))
488
(define (ensure-accessor proc . name)
489
(let ((name (and (pair? name) (car name))))
490
(cond ((and (is-a? proc <accessor>)
491
(is-a? (setter proc) <generic>))
493
((is-a? proc <generic-with-setter>)
494
(upgrade-accessor proc (setter proc)))
495
((is-a? proc <generic>)
496
(upgrade-accessor proc (make-generic name)))
497
((procedure-with-setter? proc)
500
#:default (procedure proc)
501
#:setter (ensure-generic (setter proc) name)))
503
(ensure-accessor (ensure-generic proc name) name))
505
(make-accessor name)))))
507
(define (upgrade-accessor generic setter)
508
(let ((methods (slot-ref generic 'methods))
509
(gws (make (if (is-a? generic <extended-generic>)
510
<extended-generic-with-setter>
512
#:name (generic-function-name generic)
513
#:extended-by (slot-ref generic 'extended-by)
515
(if (is-a? generic <extended-generic>)
516
(let ((gfs (slot-ref generic 'extends)))
517
(not-extended-by! gfs generic)
518
(slot-set! gws 'extends gfs)
519
(extended-by! gfs gws)))
521
(for-each (lambda (method)
522
(slot-set! method 'generic-function gws))
524
(slot-set! gws 'methods methods)
531
(define define-method
532
(procedure->memoizing-macro
534
(let ((head (cadr exp)))
535
(if (not (pair? head))
536
(goops-error "bad method head: ~S" head)
537
(let ((gf (car head)))
538
(cond ((and (pair? gf)
539
(eq? (car gf) 'setter)
543
;; named setter method
544
(let ((name (cadr gf)))
545
(cond ((not (symbol? name))
546
`(add-method! (setter ,name)
551
;; *fixme* Temporary hack for the current
554
(define-accessor ,name))
555
(add-method! (setter ,name)
560
(define-accessor ,name)
561
(add-method! (setter ,name)
565
`(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
568
;; *fixme* Temporary hack for the current
571
(define-generic ,gf))
580
,@(cddr exp))))))))))))
582
(define (make-method specializers procedure)
584
#:specializers specializers
585
#:procedure procedure))
588
(letrec ((specializers
590
(cond ((null? ls) (list (list 'quote '())))
591
((pair? ls) (cons (if (pair? (car ls))
594
(specializers (cdr ls))))
599
(cons (if (pair? (car ls)) (caar ls) (car ls))
602
(procedure->memoizing-macro
604
(let ((args (cadr exp))
607
#:specializers (cons* ,@(specializers args))
608
#:procedure (lambda ,(formals args)
617
(define (add-method-in-classes! m)
618
;; Add method in all the classes which appears in its specializers list
619
(for-each* (lambda (x)
620
(let ((dm (class-direct-methods x)))
621
(if (not (memv m dm))
622
(slot-set! x 'direct-methods (cons m dm)))))
623
(method-specializers m)))
625
(define (remove-method-in-classes! m)
626
;; Remove method in all the classes which appears in its specializers list
627
(for-each* (lambda (x)
630
(delv! m (class-direct-methods x))))
631
(method-specializers m)))
633
(define (compute-new-list-of-methods gf new)
634
(let ((new-spec (method-specializers new))
635
(methods (slot-ref gf 'methods)))
636
(let loop ((l methods))
639
(if (equal? (method-specializers (car l)) new-spec)
641
;; This spec. list already exists. Remove old method from dependents
642
(remove-method-in-classes! (car l))
647
(define (internal-add-method! gf m)
648
(slot-set! m 'generic-function gf)
649
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
650
(let ((specializers (slot-ref m 'specializers)))
651
(slot-set! gf 'n-specialized
652
(max (length* specializers)
653
(slot-ref gf 'n-specialized))))
654
(%invalidate-method-cache! gf)
655
(add-method-in-classes! m)
658
(define-generic add-method!)
660
(internal-add-method! add-method!
662
#:specializers (list <generic> <method>)
663
#:procedure internal-add-method!))
665
(define-method (add-method! (proc <procedure>) (m <method>))
666
(if (generic-capability? proc)
668
(enable-primitive-generic! proc)
669
(add-method! proc m))
672
(define-method (add-method! (pg <primitive-generic>) (m <method>))
673
(add-method! (primitive-generic-generic pg) m))
675
(define-method (add-method! obj (m <method>))
676
(goops-error "~S is not a valid generic function" obj))
679
;;; {Access to meta objects}
685
(define-method (method-source (m <method>))
686
(let* ((spec (map* class-name (slot-ref m 'specializers)))
687
(proc (procedure-source (slot-ref m 'procedure)))
691
(cons (map* list args spec)
697
(define slot-definition-name car)
699
(define slot-definition-options cdr)
701
(define (slot-definition-allocation s)
702
(get-keyword #:allocation (cdr s) #:instance))
704
(define (slot-definition-getter s)
705
(get-keyword #:getter (cdr s) #f))
707
(define (slot-definition-setter s)
708
(get-keyword #:setter (cdr s) #f))
710
(define (slot-definition-accessor s)
711
(get-keyword #:accessor (cdr s) #f))
713
(define (slot-definition-init-value s)
714
;; can be #f, so we can't use #f as non-value
715
(get-keyword #:init-value (cdr s) (make-unbound)))
717
(define (slot-definition-init-form s)
718
(get-keyword #:init-form (cdr s) (make-unbound)))
720
(define (slot-definition-init-thunk s)
721
(get-keyword #:init-thunk (cdr s) #f))
723
(define (slot-definition-init-keyword s)
724
(get-keyword #:init-keyword (cdr s) #f))
726
(define (class-slot-definition class slot-name)
727
(assq slot-name (class-slots class)))
729
(define (slot-init-function class slot-name)
730
(cadr (assq slot-name (slot-ref class 'getters-n-setters))))
734
;;; {Standard methods used by the C runtime}
737
;;; Methods to compare objects
740
(define-method (eqv? x y) #f)
741
(define-method (equal? x y) (eqv? x y))
743
;;; These following two methods are for backward compatibility only.
744
;;; They are not called by the Guile interpreter.
746
(define-method (object-eqv? x y) #f)
747
(define-method (object-equal? x y) (eqv? x y))
750
;;; methods to display/write an object
753
; Code for writing objects must test that the slots they use are
754
; bound. Otherwise a slot-unbound method will be called and will
755
; conduct to an infinite loop.
758
(define (display-address o file)
759
(display (number->string (object-address o) 16) file))
761
(define-method (write o file)
762
(display "#<instance " file)
763
(display-address o file)
766
(define write-object (primitive-generic-generic write))
768
(define-method (write (o <object>) file)
769
(let ((class (class-of o)))
770
(if (slot-bound? class 'name)
773
(display (class-name class) file)
774
(display #\space file)
775
(display-address o file)
779
(define-method (write (o <foreign-object>) file)
780
(let ((class (class-of o)))
781
(if (slot-bound? class 'name)
783
(display "#<foreign-object " file)
784
(display (class-name class) file)
785
(display #\space file)
786
(display-address o file)
790
(define-method (write (class <class>) file)
791
(let ((meta (class-of class)))
792
(if (and (slot-bound? class 'name)
793
(slot-bound? meta 'name))
796
(display (class-name meta) file)
797
(display #\space file)
798
(display (class-name class) file)
799
(display #\space file)
800
(display-address class file)
804
(define-method (write (gf <generic>) file)
805
(let ((meta (class-of gf)))
806
(if (and (slot-bound? meta 'name)
807
(slot-bound? gf 'methods))
810
(display (class-name meta) file)
811
(let ((name (generic-function-name gf)))
814
(display #\space file)
815
(display name file))))
817
(display (length (generic-function-methods gf)) file)
821
(define-method (write (o <method>) file)
822
(let ((meta (class-of o)))
823
(if (and (slot-bound? meta 'name)
824
(slot-bound? o 'specializers))
827
(display (class-name meta) file)
828
(display #\space file)
829
(display (map* (lambda (spec)
830
(if (slot-bound? spec 'name)
831
(slot-ref spec 'name)
833
(method-specializers o))
835
(display #\space file)
836
(display-address o file)
840
;; Display (do the same thing as write by default)
841
(define-method (display o file)
842
(write-object o file))
845
;;; Handling of duplicate bindings in the module system
848
(define-method (merge-generics (module <module>)
858
(define-method (merge-generics (module <module>)
866
(and (not (eq? val1 val2))
867
(make-variable (make-extended-generic (list val2 val1) name))))
869
(define-method (merge-generics (module <module>)
876
(gf <extended-generic>))
877
(and (not (memq val2 (slot-ref gf 'extends)))
881
(cons val2 (delq! val2 (slot-ref gf 'extends))))
884
(cons gf (delq! gf (slot-ref val2 'extended-by))))
887
(module-define! duplicate-handlers 'merge-generics merge-generics)
889
(define-method (merge-accessors (module <module>)
899
(define-method (merge-accessors (module <module>)
907
(merge-generics module name int1 val1 int2 val2 var val))
909
(module-define! duplicate-handlers 'merge-accessors merge-accessors)
915
(define (class-slot-g-n-s class slot-name)
916
(let* ((this-slot (assq slot-name (slot-ref class 'slots)))
917
(g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
918
(slot-missing class slot-name)))))
919
(if (not (memq (slot-definition-allocation this-slot)
920
'(#:class #:each-subclass)))
921
(slot-missing class slot-name))
924
(define (class-slot-ref class slot)
925
(let ((x ((car (class-slot-g-n-s class slot)) #f)))
927
(slot-unbound class slot)
930
(define (class-slot-set! class slot value)
931
((cadr (class-slot-g-n-s class slot)) #f value))
933
(define-method (slot-unbound (c <class>) (o <object>) s)
934
(goops-error "Slot `~S' is unbound in object ~S" s o))
936
(define-method (slot-unbound (c <class>) s)
937
(goops-error "Slot `~S' is unbound in class ~S" s c))
939
(define-method (slot-unbound (o <object>))
940
(goops-error "Unbound slot in object ~S" o))
942
(define-method (slot-missing (c <class>) (o <object>) s)
943
(goops-error "No slot with name `~S' in object ~S" s o))
945
(define-method (slot-missing (c <class>) s)
946
(goops-error "No class slot with name `~S' in class ~S" s c))
949
(define-method (slot-missing (c <class>) (o <object>) s value)
950
(slot-missing c o s))
952
;;; Methods for the possible error we can encounter when calling a gf
954
(define-method (no-next-method (gf <generic>) args)
955
(goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
957
(define-method (no-applicable-method (gf <generic>) args)
958
(goops-error "No applicable method for ~S in call ~S"
959
gf (cons (generic-function-name gf) args)))
961
(define-method (no-method (gf <generic>) args)
962
(goops-error "No method defined for ~S" gf))
965
;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
968
(define-method (shallow-clone (self <object>))
969
(let ((clone (%allocate-instance (class-of self) '()))
970
(slots (map slot-definition-name
971
(class-slots (class-of self)))))
972
(for-each (lambda (slot)
973
(if (slot-bound? self slot)
974
(slot-set! clone slot (slot-ref self slot))))
978
(define-method (deep-clone (self <object>))
979
(let ((clone (%allocate-instance (class-of self) '()))
980
(slots (map slot-definition-name
981
(class-slots (class-of self)))))
982
(for-each (lambda (slot)
983
(if (slot-bound? self slot)
984
(slot-set! clone slot
985
(let ((value (slot-ref self slot)))
986
(if (instance? value)
993
;;; {Class redefinition utilities}
996
;;; (class-redefinition OLD NEW)
999
;;; Has correct the following conditions:
1003
;;; 1. New accessor specializers refer to new header
1007
;;; 1. New class cpl refers to the new class header
1008
;;; 2. Old class header exists on old super classes direct-subclass lists
1009
;;; 3. New class header exists on new super classes direct-subclass lists
1011
(define-method (class-redefinition (old <class>) (new <class>))
1012
;; Work on direct methods:
1013
;; 1. Remove accessor methods from the old class
1014
;; 2. Patch the occurences of new in the specializers by old
1015
;; 3. Displace the methods from old to new
1016
(remove-class-accessors! old) ;; -1-
1017
(let ((methods (class-direct-methods new)))
1018
(for-each (lambda (m)
1019
(update-direct-method! m new old)) ;; -2-
1023
(append methods (class-direct-methods old))))
1025
;; Substitute old for new in new cpl
1026
(set-car! (slot-ref new 'cpl) old)
1028
;; Remove the old class from the direct-subclasses list of its super classes
1029
(for-each (lambda (c) (slot-set! c 'direct-subclasses
1030
(delv! old (class-direct-subclasses c))))
1031
(class-direct-supers old))
1033
;; Replace the new class with the old in the direct-subclasses of the supers
1034
(for-each (lambda (c)
1035
(slot-set! c 'direct-subclasses
1036
(cons old (delv! new (class-direct-subclasses c)))))
1037
(class-direct-supers new))
1039
;; Swap object headers
1040
(%modify-class old new)
1044
;; Redefine all the subclasses of old to take into account modification
1047
(update-direct-subclass! c new old))
1048
(class-direct-subclasses new))
1050
;; Invalidate class so that subsequent instances slot accesses invoke
1051
;; change-object-class
1052
(slot-set! new 'redefined old)
1053
(%invalidate-class new) ;must come after slot-set!
1058
;;; remove-class-accessors!
1061
(define-method (remove-class-accessors! (c <class>))
1062
(for-each (lambda (m)
1063
(if (is-a? m <accessor-method>)
1064
(let ((gf (slot-ref m 'generic-function)))
1065
;; remove the method from its GF
1066
(slot-set! gf 'methods
1067
(delq1! m (slot-ref gf 'methods)))
1068
(%invalidate-method-cache! gf)
1069
;; remove the method from its specializers
1070
(remove-method-in-classes! m))))
1071
(class-direct-methods c)))
1074
;;; update-direct-method!
1077
(define-method (update-direct-method! (m <method>)
1080
(let loop ((l (method-specializers m)))
1081
;; Note: the <top> in dotted list is never used.
1082
;; So we can work as if we had only proper lists.
1085
(if (eqv? (car l) old)
1090
;;; update-direct-subclass!
1093
(define-method (update-direct-subclass! (c <class>)
1096
(class-redefinition c
1097
(make-class (class-direct-supers c)
1098
(class-direct-slots c)
1099
#:name (class-name c)
1100
#:environment (slot-ref c 'environment)
1101
#:metaclass (class-of c))))
1104
;;; {Utilities for INITIALIZE methods}
1107
;;; compute-slot-accessors
1109
(define (compute-slot-accessors class slots env)
1112
(let ((name (slot-definition-name s))
1113
(getter-function (slot-definition-getter s))
1114
(setter-function (slot-definition-setter s))
1115
(accessor (slot-definition-accessor s)))
1117
(add-method! getter-function
1118
(compute-getter-method class g-n-s)))
1120
(add-method! setter-function
1121
(compute-setter-method class g-n-s)))
1124
(add-method! accessor
1125
(compute-getter-method class g-n-s))
1126
(add-method! (setter accessor)
1127
(compute-setter-method class g-n-s))))))
1128
slots (slot-ref class 'getters-n-setters)))
1130
(define-method (compute-getter-method (class <class>) slotdef)
1131
(let ((init-thunk (cadr slotdef))
1132
(g-n-s (cddr slotdef)))
1133
(make <accessor-method>
1134
#:specializers (list class)
1135
#:procedure (cond ((pair? g-n-s)
1136
(make-generic-bound-check-getter (car g-n-s)))
1138
(standard-get g-n-s))
1140
(bound-check-get g-n-s)))
1141
#:slot-definition slotdef)))
1143
(define-method (compute-setter-method (class <class>) slotdef)
1144
(let ((g-n-s (cddr slotdef)))
1145
(make <accessor-method>
1146
#:specializers (list class <top>)
1147
#:procedure (if (pair? g-n-s)
1149
(standard-set g-n-s))
1150
#:slot-definition slotdef)))
1152
(define (make-generic-bound-check-getter proc)
1153
(let ((source (and (closure? proc) (procedure-source proc))))
1154
(if (and source (null? (cdddr source)))
1155
(let ((obj (caadr source)))
1156
;; smart closure compilation
1158
`(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
1159
(procedure-environment proc)))
1160
(lambda (o) (assert-bound (proc o) o)))))
1162
(define n-standard-accessor-methods 10)
1164
(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
1165
(define standard-get-methods (make-vector n-standard-accessor-methods #f))
1166
(define standard-set-methods (make-vector n-standard-accessor-methods #f))
1168
(define (standard-accessor-method make methods)
1170
(cond ((>= index n-standard-accessor-methods) (make index))
1171
((vector-ref methods index))
1172
(else (let ((m (make index)))
1173
(vector-set! methods index m)
1176
(define (make-bound-check-get index)
1177
(local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
1179
(define (make-get index)
1180
(local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
1182
(define (make-set index)
1183
(local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
1185
(define bound-check-get
1186
(standard-accessor-method make-bound-check-get bound-check-get-methods))
1187
(define standard-get (standard-accessor-method make-get standard-get-methods))
1188
(define standard-set (standard-accessor-method make-set standard-set-methods))
1190
;;; compute-getters-n-setters
1192
(define (make-thunk thunk)
1193
(lambda () (thunk)))
1195
(define (compute-getters-n-setters class slots env)
1197
(define (compute-slot-init-function name s)
1198
(or (let ((thunk (slot-definition-init-thunk s)))
1200
(cond ((not (thunk? thunk))
1201
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
1203
((closure? thunk) thunk)
1204
(else (make-thunk thunk)))))
1205
(let ((init (slot-definition-init-value s)))
1206
(and (not (unbound? init))
1207
(lambda () init)))))
1209
(define (verify-accessors slot l)
1210
(cond ((integer? l))
1211
((not (and (list? l) (= (length l) 2)))
1212
(goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
1217
(if (not (and (closure? get)
1218
(= (car (procedure-property get 'arity)) 1)))
1219
(goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1221
(if (not (and (closure? set)
1222
(= (car (procedure-property set 'arity)) 2)))
1223
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1224
slot class set))))))
1227
;; The strange treatment of nfields is due to backward compatibility.
1228
(let* ((index (slot-ref class 'nfields))
1229
(g-n-s (compute-get-n-set class s))
1230
(size (- (slot-ref class 'nfields) index))
1231
(name (slot-definition-name s)))
1232
;; NOTE: The following is interdependent with C macros
1233
;; defined above goops.c:scm_sys_prep_layout_x.
1235
;; For simple instance slots, we have the simplest form
1236
;; '(name init-function . index)
1237
;; For other slots we have
1238
;; '(name init-function getter setter . alloc)
1240
;; '(index size) for instance allocated slots
1241
;; '() for other slots
1242
(verify-accessors name g-n-s)
1244
(cons (compute-slot-init-function name s)
1245
(if (or (integer? g-n-s)
1248
(append g-n-s (list index size)))))))
1253
;;; Correct behaviour:
1255
;;; (define-class food ())
1256
;;; (define-class fruit (food))
1257
;;; (define-class spice (food))
1258
;;; (define-class apple (fruit))
1259
;;; (define-class cinnamon (spice))
1260
;;; (define-class pie (apple cinnamon))
1261
;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1263
;;; (define-class d ())
1264
;;; (define-class e ())
1265
;;; (define-class f ())
1266
;;; (define-class b (d e))
1267
;;; (define-class c (e f))
1268
;;; (define-class a (b c))
1269
;;; => cpl (a) = a b d c e f object top
1272
(define-method (compute-cpl (class <class>))
1273
(compute-std-cpl class class-direct-supers))
1277
(define (only-non-null lst)
1278
(filter (lambda (l) (not (null? l))) lst))
1280
(define (compute-std-cpl c get-direct-supers)
1281
(let ((c-direct-supers (get-direct-supers c)))
1282
(merge-lists (list c)
1283
(only-non-null (append (map class-precedence-list
1285
(list c-direct-supers))))))
1287
(define (merge-lists reversed-partial-result inputs)
1289
((every null? inputs)
1290
(reverse! reversed-partial-result))
1292
(let* ((candidate (lambda (c)
1293
(and (not (any (lambda (l)
1297
(candidate-car (lambda (l)
1298
(and (not (null? l))
1299
(candidate (car l)))))
1300
(next (any candidate-car inputs)))
1302
(goops-error "merge-lists: Inconsistent precedence graph"))
1303
(let ((remove-next (lambda (l)
1304
(if (eq? (car l) next)
1307
(merge-lists (cons next reversed-partial-result)
1308
(only-non-null (map remove-next inputs))))))))
1310
;; Modified from TinyClos:
1312
;; A simple topological sort.
1314
;; It's in this file so that both TinyClos and Objects can use it.
1316
;; This is a fairly modified version of code I originally got from Anurag
1317
;; Mendhekar <anurag@moose.cs.indiana.edu>.
1320
(define (compute-clos-cpl c get-direct-supers)
1321
(top-sort ((build-transitive-closure get-direct-supers) c)
1322
((build-constraints get-direct-supers) c)
1323
(std-tie-breaker get-direct-supers)))
1326
(define (top-sort elements constraints tie-breaker)
1327
(let loop ((elements elements)
1328
(constraints constraints)
1330
(if (null? elements)
1332
(let ((can-go-in-now
1335
(every (lambda (constraint)
1336
(or (not (eq? (cadr constraint) x))
1337
(memq (car constraint) result)))
1340
(if (null? can-go-in-now)
1341
(goops-error "top-sort: Invalid constraints")
1342
(let ((choice (if (null? (cdr can-go-in-now))
1347
(filter (lambda (x) (not (eq? x choice)))
1350
(append result (list choice)))))))))
1352
(define (std-tie-breaker get-supers)
1353
(lambda (partial-cpl min-elts)
1354
(let loop ((pcpl (reverse partial-cpl)))
1355
(let ((current-elt (car pcpl)))
1356
(let ((ds-of-ce (get-supers current-elt)))
1357
(let ((common (filter (lambda (x)
1361
(if (null? (cdr pcpl))
1362
(goops-error "std-tie-breaker: Nothing valid")
1367
(define (build-transitive-closure get-follow-ons)
1369
(let track ((result '())
1373
(let ((next (car pending)))
1374
(if (memq next result)
1375
(track result (cdr pending))
1376
(track (cons next result)
1377
(append (get-follow-ons next)
1378
(cdr pending)))))))))
1380
(define (build-constraints get-follow-ons)
1382
(let loop ((elements ((build-transitive-closure get-follow-ons) x))
1385
(if (or (null? this-one) (null? (cdr this-one)))
1386
(if (null? elements)
1388
(loop (cdr elements)
1389
(cons (car elements)
1390
(get-follow-ons (car elements)))
1394
(cons (list (car this-one) (cadr this-one))
1397
;;; compute-get-n-set
1399
(define-method (compute-get-n-set (class <class>) s)
1400
(case (slot-definition-allocation s)
1401
((#:instance) ;; Instance slot
1402
;; get-n-set is just its offset
1403
(let ((already-allocated (slot-ref class 'nfields)))
1404
(slot-set! class 'nfields (+ already-allocated 1))
1407
((#:class) ;; Class slot
1408
;; Class-slots accessors are implemented as 2 closures around
1409
;; a Scheme variable. As instance slots, class slots must be
1410
;; unbound at init time.
1411
(let ((name (slot-definition-name s)))
1412
(if (memq name (map slot-definition-name (class-direct-slots class)))
1413
;; This slot is direct; create a new shared variable
1414
(make-closure-variable class)
1415
;; Slot is inherited. Find its definition in superclass
1416
(let loop ((l (cdr (class-precedence-list class))))
1417
(let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1420
(loop (cdr l))))))))
1422
((#:each-subclass) ;; slot shared by instances of direct subclass.
1423
;; (Thomas Buerger, April 1998)
1424
(make-closure-variable class))
1426
((#:virtual) ;; No allocation
1427
;; slot-ref and slot-set! function must be given by the user
1428
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
1429
(set (get-keyword #:slot-set! (slot-definition-options s) #f))
1430
(env (class-environment class)))
1431
(if (not (and get set))
1432
(goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
1435
(else (next-method))))
1437
(define (make-closure-variable class)
1438
(let ((shared-variable (make-unbound)))
1439
(list (lambda (o) shared-variable)
1440
(lambda (o v) (set! shared-variable v)))))
1442
(define-method (compute-get-n-set (o <object>) s)
1443
(goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1445
(define-method (compute-slots (class <class>))
1446
(%compute-slots class))
1452
(define-method (initialize (object <object>) initargs)
1453
(%initialize-object object initargs))
1455
(define-method (initialize (class <class>) initargs)
1457
(let ((dslots (get-keyword #:slots initargs '()))
1458
(supers (get-keyword #:dsupers initargs '()))
1459
(env (get-keyword #:environment initargs (top-level-env))))
1461
(slot-set! class 'name (get-keyword #:name initargs '???))
1462
(slot-set! class 'direct-supers supers)
1463
(slot-set! class 'direct-slots dslots)
1464
(slot-set! class 'direct-subclasses '())
1465
(slot-set! class 'direct-methods '())
1466
(slot-set! class 'cpl (compute-cpl class))
1467
(slot-set! class 'redefined #f)
1468
(slot-set! class 'environment env)
1469
(let ((slots (compute-slots class)))
1470
(slot-set! class 'slots slots)
1471
(slot-set! class 'nfields 0)
1472
(slot-set! class 'getters-n-setters (compute-getters-n-setters class
1475
;; Build getters - setters - accessors
1476
(compute-slot-accessors class slots env))
1478
;; Update the "direct-subclasses" of each inherited classes
1479
(for-each (lambda (x)
1482
(cons class (slot-ref x 'direct-subclasses))))
1485
;; Support for the underlying structs:
1487
;; Inherit class flags (invisible on scheme level) from supers
1488
(%inherit-magic! class supers)
1490
;; Set the layout slot
1491
(%prep-layout! class)))
1493
(define (initialize-object-procedure object initargs)
1494
(let ((proc (get-keyword #:procedure initargs #f)))
1497
(apply set-object-procedure! object proc))
1498
((valid-object-procedure? proc)
1499
(set-object-procedure! object proc))
1501
(set-object-procedure! object
1502
(lambda args (apply proc args)))))))
1504
(define-method (initialize (class <operator-class>) initargs)
1506
(initialize-object-procedure class initargs))
1508
(define-method (initialize (owsc <operator-with-setter-class>) initargs)
1510
(%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1512
(define-method (initialize (entity <entity>) initargs)
1514
(initialize-object-procedure entity initargs))
1516
(define-method (initialize (ews <entity-with-setter>) initargs)
1518
(%set-object-setter! ews (get-keyword #:setter initargs #f)))
1520
(define-method (initialize (generic <generic>) initargs)
1521
(let ((previous-definition (get-keyword #:default initargs #f))
1522
(name (get-keyword #:name initargs #f)))
1524
(slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1525
(list (make <method>
1526
#:specializers <top>
1529
(apply previous-definition
1533
(set-procedure-property! generic 'name name))
1536
(define-method (initialize (eg <extended-generic>) initargs)
1538
(slot-set! eg 'extends (get-keyword #:extends initargs '())))
1540
(define dummy-procedure (lambda args *unspecified*))
1542
(define-method (initialize (method <method>) initargs)
1544
(slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1545
(slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1546
(slot-set! method 'procedure
1547
(get-keyword #:procedure initargs dummy-procedure))
1548
(slot-set! method 'code-table '()))
1550
(define-method (initialize (obj <foreign-object>) initargs))
1556
(define (change-object-class old-instance old-class new-class)
1557
(let ((new-instance (allocate-instance new-class '())))
1558
;; Initialize the slots of the new instance
1559
(for-each (lambda (slot)
1560
(if (and (slot-exists-using-class? old-class old-instance slot)
1561
(eq? (slot-definition-allocation
1562
(class-slot-definition old-class slot))
1564
(slot-bound-using-class? old-class old-instance slot))
1565
;; Slot was present and allocated in old instance; copy it
1566
(slot-set-using-class!
1570
(slot-ref-using-class old-class old-instance slot))
1571
;; slot was absent; initialize it with its default value
1572
(let ((init (slot-init-function new-class slot)))
1574
(slot-set-using-class!
1578
(apply init '()))))))
1579
(map slot-definition-name (class-slots new-class)))
1580
;; Exchange old and new instance in place to keep pointers valid
1581
(%modify-instance old-instance new-instance)
1582
;; Allow class specific updates of instances (which now are swapped)
1583
(update-instance-for-different-class new-instance old-instance)
1587
(define-method (update-instance-for-different-class (old-instance <object>)
1590
;;not really important what we do, we just need a default method
1593
(define-method (change-class (old-instance <object>) (new-class <class>))
1594
(change-object-class old-instance (class-of old-instance) new-class))
1599
;;; A new definition which overwrites the previous one which was built-in
1602
(define-method (allocate-instance (class <class>) initargs)
1603
(%allocate-instance class initargs))
1605
(define-method (make-instance (class <class>) . initargs)
1606
(let ((instance (allocate-instance class initargs)))
1607
(initialize instance initargs)
1610
(define make make-instance)
1615
;;; Protocol for calling standard generic functions. This protocol is
1616
;;; not used for real <generic> functions (in this case we use a
1617
;;; completely C hard-coded protocol). Apply-generic is used by
1618
;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1619
;;; The code below is similar to the first MOP described in AMOP. In
1620
;;; particular, it doesn't used the currified approach to gf
1621
;;; call. There are 2 reasons for that:
1622
;;; - the protocol below is exposed to mimic completely the one written in C
1623
;;; - the currified protocol would be imho inefficient in C.
1626
(define-method (apply-generic (gf <generic>) args)
1627
(if (null? (slot-ref gf 'methods))
1628
(no-method gf args))
1629
(let ((methods (compute-applicable-methods gf args)))
1631
(apply-methods gf (sort-applicable-methods gf methods args) args)
1632
(no-applicable-method gf args))))
1634
;; compute-applicable-methods is bound to %compute-applicable-methods.
1636
(define %%compute-applicable-methods
1637
(make <generic> #:name 'compute-applicable-methods))
1639
(define-method (%%compute-applicable-methods (gf <generic>) args)
1640
(%compute-applicable-methods gf args))
1642
(set! compute-applicable-methods %%compute-applicable-methods)
1644
(define-method (sort-applicable-methods (gf <generic>) methods args)
1645
(let ((targs (map class-of args)))
1646
(sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1648
(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1649
(%method-more-specific? m1 m2 targs))
1651
(define-method (apply-method (gf <generic>) methods build-next args)
1652
(apply (method-procedure (car methods))
1653
(build-next (cdr methods) args)
1656
(define-method (apply-methods (gf <generic>) (l <list>) args)
1657
(letrec ((next (lambda (procs args)
1659
(let ((a (if (null? new-args) args new-args)))
1661
(no-next-method gf a)
1662
(apply-method gf procs next a)))))))
1663
(apply-method gf l next args)))
1665
;; We don't want the following procedure to turn up in backtraces:
1666
(for-each (lambda (proc)
1667
(set-procedure-property! proc 'system-procedure #t))
1671
no-applicable-method
1676
;;; {<composite-metaclass> and <active-metaclass>}
1679
;(autoload "active-slot" <active-metaclass>)
1680
;(autoload "composite-slot" <composite-metaclass>)
1681
;(export <composite-metaclass> <active-metaclass>)
1689
;; duplicate the standard list->set function but using eq instead of
1690
;; eqv which really sucks a lot, uselessly here
1692
(define (list2set l)
1697
((memq (car l) res) (loop (cdr l) res))
1698
(else (loop (cdr l) (cons (car l) res))))))
1700
(define (class-subclasses c)
1701
(letrec ((allsubs (lambda (c)
1702
(cons c (mapappend allsubs
1703
(class-direct-subclasses c))))))
1704
(list2set (cdr (allsubs c)))))
1706
(define (class-methods c)
1707
(list2set (mapappend class-direct-methods
1708
(cons c (class-subclasses c)))))
1711
;;; {Final initialization}
1714
;; Tell C code that the main bulk of Goops has been loaded
added
removed
oop/goops.scm
