3 ;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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
30 define-generic define-accessor define-method
31 define-extended-generic define-extended-generics
33 :export (goops-version is-a?
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>)
80 :re-export (class-of) ;; from (guile)
83 ;; First initialize the builtin part of GOOPS
84 (%init-goops-builtins)
86 ;; Then load the rest of GOOPS
87 (use-modules (oop goops util)
92 (define min-fixnum (- (expt 2 29)))
94 (define max-fixnum (- (expt 2 29) 1))
99 (define (goops-error format-string . args)
101 (scm-error 'goops-error #f format-string args '()))
106 (define (is-a? obj class)
107 (and (memq class (class-precedence-list (class-of obj))) #t))
114 (define ensure-metaclass-with-supers
115 (let ((table-of-metas '()))
116 (lambda (meta-supers)
117 (let ((entry (assoc meta-supers table-of-metas)))
119 ;; Found a previously created metaclass
121 ;; Create a new meta-class which inherit from "meta-supers"
122 (let ((new (make <class> #:dsupers meta-supers
124 #:name (gensym "metaclass"))))
125 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
128 (define (ensure-metaclass supers env)
131 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
132 (all-cpls (apply append
134 (cdr (class-precedence-list m)))
137 ;; Find the most specific metaclasses. The new metaclass will be
138 ;; a subclass of these.
141 (if (and (not (member meta all-cpls))
142 (not (member meta needed-metas)))
143 (set! needed-metas (append needed-metas (list meta)))))
145 ;; Now return a subclass of the metaclasses we found.
146 (if (null? (cdr needed-metas))
147 (car needed-metas) ; If there's only one, just use it.
148 (ensure-metaclass-with-supers needed-metas)))))
154 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
156 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
157 ;;; OPTION ::= KEYWORD VALUE
159 (define (define-class-pre-definition keyword exp env)
162 `(process-class-pre-define-generic ',exp))
164 `(process-class-pre-define-accessor ',exp))
167 (define (process-class-pre-define-generic name)
168 (let ((var (module-variable (current-module) name)))
170 (variable-bound? var)
171 (is-a? (variable-ref var) <generic>)))
172 (process-define-generic name))))
174 (define (process-class-pre-define-accessor name)
175 (let ((var (module-variable (current-module) name)))
177 (not (variable-bound? var)))
178 (process-define-accessor name))
179 ((or (is-a? (variable-ref var) <accessor>)
180 (is-a? (variable-ref var) <extended-generic-with-setter>)))
181 ((is-a? (variable-ref var) <generic>)
182 ;;*fixme* don't mutate an imported object!
183 (variable-set! var (ensure-accessor (variable-ref var) name)))
185 (process-define-accessor name)))))
187 ;;; This code should be implemented in C.
190 (letrec (;; Some slot options require extra definitions to be made.
191 ;; In particular, we want to make sure that the generic
192 ;; function objects which represent accessors exist
193 ;; before `make-class' tries to add methods to them.
195 ;; Postpone error handling to class macro.
199 (do ((slots slots (cdr slots))
201 (if (pair? (car slots))
202 (do ((options (cdar slots) (cddr options))
203 (definitions definitions
204 (cond ((not (symbol? (cadr options)))
206 ((define-class-pre-definition
210 => (lambda (definition)
211 (cons definition definitions)))
212 (else definitions))))
213 ((not (and (pair? options)
214 (pair? (cdr options))))
217 ((or (not (pair? slots))
218 (keyword? (car slots)))
219 (reverse definitions)))))
225 (procedure->memoizing-macro
227 (cond ((not (top-level-env? env))
228 (goops-error "define-class: Only allowed at top level"))
229 ((not (and (list? exp) (>= (length exp) 3)))
230 (goops-error "missing or extra expression"))
232 (let ((name (name exp)))
235 ,@(pre-definitions (slots exp) env)
236 ;; update the current-module
237 (let* ((class (class ,@(cddr exp) #:name ',name))
238 (var (module-ensure-local-variable!
239 (current-module) ',name))
240 (old (and (variable-bound? var)
241 (variable-ref var))))
244 (memq <object> (class-precedence-list old)))
245 (variable-set! var (class-redefinition old class))
246 (variable-set! var class)))))))))))
248 (defmacro standard-define-class args
249 `(define-class ,@args))
251 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
253 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
254 ;;; OPTION ::= KEYWORD VALUE
257 (letrec ((slot-option-keyword car)
258 (slot-option-value cadr)
259 (process-slot-options
261 (let loop ((options options)
263 (cond ((null? options)
265 ((null? (cdr options))
266 (goops-error "malformed slot option list"))
267 ((not (keyword? (slot-option-keyword options)))
268 (goops-error "malformed slot option list"))
270 (case (slot-option-keyword options)
273 (append (list `(lambda ()
274 ,(slot-option-value options))
277 (slot-option-value options))
286 (procedure->memoizing-macro
291 (cond ((not (and (list? exp) (>= (length exp) 2)))
292 (goops-error "missing or extra expression"))
293 ((not (list? (supers exp)))
294 (goops-error "malformed superclass list: ~S" (supers exp)))
296 (let ((slot-defs (cons #f '())))
297 (do ((slots (slots exp) (cdr slots))
298 (defs slot-defs (cdr defs)))
300 (keyword? (car slots)))
302 ;; evaluate super class variables
303 (list ,@(supers exp))
304 ;; evaluate slot definitions, except the slot name!
305 (list ,@(cdr slot-defs))
306 ;; evaluate class options
308 ;; place option last in case someone wants to
309 ;; pass a different value
310 #:environment ',env))
313 (list (if (pair? (car slots))
314 `(list ',(slot-definition-name (car slots))
315 ,@(process-slot-options
316 (slot-definition-options
318 `(list ',(car slots))))))))))))))
320 (define (make-class supers slots . options)
321 (let ((env (or (get-keyword #:environment options #f)
323 (let* ((name (get-keyword #:name options (make-unbound)))
324 (supers (if (not (or-map (lambda (class)
326 (class-precedence-list class)))
328 (append supers (list <object>))
330 (metaclass (or (get-keyword #:metaclass options #f)
331 (ensure-metaclass supers env))))
333 ;; Verify that all direct slots are different and that we don't inherit
334 ;; several time from the same class
335 (let ((tmp1 (find-duplicate supers))
336 (tmp2 (find-duplicate (map slot-definition-name slots))))
338 (goops-error "make-class: super class ~S is duplicate in class ~S"
341 (goops-error "make-class: slot ~S is duplicate in class ~S"
344 ;; Everything seems correct, build the class
345 (apply make metaclass
353 ;;; {Generic functions and accessors}
356 (define define-generic
357 (procedure->memoizing-macro
359 (let ((name (cadr exp)))
360 (cond ((not (symbol? name))
361 (goops-error "bad generic function name: ~S" name))
362 ((top-level-env? env)
363 `(process-define-generic ',name))
365 `(define ,name (make <generic> #:name ',name))))))))
367 (define (process-define-generic name)
368 (let ((var (module-ensure-local-variable! (current-module) name)))
370 (not (variable-bound? var))
371 (is-a? (variable-ref var) <generic>))
372 ;; redefine if NAME isn't defined previously, or is another generic
373 (variable-set! var (make <generic> #:name name))
374 ;; otherwise try to upgrade the object to a generic
375 (variable-set! var (ensure-generic (variable-ref var) name)))))
377 (define define-extended-generic
378 (procedure->memoizing-macro
380 (let ((name (cadr exp)))
381 (cond ((not (symbol? name))
382 (goops-error "bad generic function name: ~S" name))
384 (goops-error "missing expression"))
386 `(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
387 (define define-extended-generics
388 (procedure->memoizing-macro
390 (let ((names (cadr exp))
391 (prefixes (get-keyword #:prefix (cddr exp) #f)))
394 ,@(map (lambda (name)
395 `(define-extended-generic ,name
396 (list ,@(map (lambda (prefix)
397 (symbol-append prefix name))
400 (goops-error "no prefixes supplied"))))))
402 (define (make-generic . name)
403 (let ((name (and (pair? name) (car name))))
404 (make <generic> #:name name)))
406 (define (make-extended-generic gfs . name)
407 (let* ((name (and (pair? name) (car name)))
408 (gfs (if (pair? gfs) gfs (list gfs)))
409 (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
411 (let* ((sname (and name (make-setter-name name)))
415 (if (is-a? gf <generic-with-setter>)
416 (list (ensure-generic (setter gf)
420 (es (make <extended-generic-with-setter>
423 #:setter (make <extended-generic>
425 #:extends setters))))
426 (extended-by! setters (setter es))
428 (make <extended-generic>
431 (extended-by! gfs ans)
434 (define (extended-by! gfs eg)
435 (for-each (lambda (gf)
436 (slot-set! gf 'extended-by
437 (cons eg (slot-ref gf 'extended-by))))
440 (define (not-extended-by! gfs eg)
441 (for-each (lambda (gf)
442 (slot-set! gf 'extended-by
443 (delq! eg (slot-ref gf 'extended-by))))
446 (define (ensure-generic old-definition . name)
447 (let ((name (and (pair? name) (car name))))
448 (cond ((is-a? old-definition <generic>) old-definition)
449 ((procedure-with-setter? old-definition)
450 (make <generic-with-setter>
452 #:default (procedure old-definition)
453 #:setter (setter old-definition)))
454 ((procedure? old-definition)
455 (make <generic> #:name name #:default old-definition))
456 (else (make <generic> #:name name)))))
458 (define define-accessor
459 (procedure->memoizing-macro
461 (let ((name (cadr exp)))
462 (cond ((not (symbol? name))
463 (goops-error "bad accessor name: ~S" name))
464 ((top-level-env? env)
465 `(process-define-accessor ',name))
467 `(define ,name (make-accessor ',name))))))))
469 (define (process-define-accessor name)
470 (let ((var (module-ensure-local-variable! (current-module) name)))
472 (not (variable-bound? var))
473 (is-a? (variable-ref var) <accessor>)
474 (is-a? (variable-ref var) <extended-generic-with-setter>))
475 ;; redefine if NAME isn't defined previously, or is another accessor
476 (variable-set! var (make-accessor name))
477 ;; otherwise try to upgrade the object to an accessor
478 (variable-set! var (ensure-accessor (variable-ref var) name)))))
480 (define (make-setter-name name)
481 (string->symbol (string-append "setter:" (symbol->string name))))
483 (define (make-accessor . name)
484 (let ((name (and (pair? name) (car name))))
487 #:setter (make <generic>
488 #:name (and name (make-setter-name name))))))
490 (define (ensure-accessor proc . name)
491 (let ((name (and (pair? name) (car name))))
492 (cond ((and (is-a? proc <accessor>)
493 (is-a? (setter proc) <generic>))
495 ((is-a? proc <generic-with-setter>)
496 (upgrade-accessor proc (setter proc)))
497 ((is-a? proc <generic>)
498 (upgrade-accessor proc (make-generic name)))
499 ((procedure-with-setter? proc)
502 #:default (procedure proc)
503 #:setter (ensure-generic (setter proc) name)))
505 (ensure-accessor (ensure-generic proc name) name))
507 (make-accessor name)))))
509 (define (upgrade-accessor generic setter)
510 (let ((methods (slot-ref generic 'methods))
511 (gws (make (if (is-a? generic <extended-generic>)
512 <extended-generic-with-setter>
514 #:name (generic-function-name generic)
515 #:extended-by (slot-ref generic 'extended-by)
517 (if (is-a? generic <extended-generic>)
518 (let ((gfs (slot-ref generic 'extends)))
519 (not-extended-by! gfs generic)
520 (slot-set! gws 'extends gfs)
521 (extended-by! gfs gws)))
523 (for-each (lambda (method)
524 (slot-set! method 'generic-function gws))
526 (slot-set! gws 'methods methods)
533 (define define-method
534 (procedure->memoizing-macro
536 (let ((head (cadr exp)))
537 (if (not (pair? head))
538 (goops-error "bad method head: ~S" head)
539 (let ((gf (car head)))
540 (cond ((and (pair? gf)
541 (eq? (car gf) 'setter)
545 ;; named setter method
546 (let ((name (cadr gf)))
547 (cond ((not (symbol? name))
548 `(add-method! (setter ,name)
553 ;; *fixme* Temporary hack for the current
556 (define-accessor ,name))
557 (add-method! (setter ,name)
562 (define-accessor ,name)
563 (add-method! (setter ,name)
567 `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
570 ;; *fixme* Temporary hack for the current
573 (define-generic ,gf))
582 ,@(cddr exp))))))))))))
584 (define (make-method specializers procedure)
586 #:specializers specializers
587 #:procedure procedure))
590 (letrec ((specializers
592 (cond ((null? ls) (list (list 'quote '())))
593 ((pair? ls) (cons (if (pair? (car ls))
596 (specializers (cdr ls))))
601 (cons (if (pair? (car ls)) (caar ls) (car ls))
604 (procedure->memoizing-macro
606 (let ((args (cadr exp))
609 #:specializers (cons* ,@(specializers args))
610 #:procedure (lambda ,(formals args)
619 (define (add-method-in-classes! m)
620 ;; Add method in all the classes which appears in its specializers list
621 (for-each* (lambda (x)
622 (let ((dm (class-direct-methods x)))
623 (if (not (memv m dm))
624 (slot-set! x 'direct-methods (cons m dm)))))
625 (method-specializers m)))
627 (define (remove-method-in-classes! m)
628 ;; Remove method in all the classes which appears in its specializers list
629 (for-each* (lambda (x)
632 (delv! m (class-direct-methods x))))
633 (method-specializers m)))
635 (define (compute-new-list-of-methods gf new)
636 (let ((new-spec (method-specializers new))
637 (methods (slot-ref gf 'methods)))
638 (let loop ((l methods))
641 (if (equal? (method-specializers (car l)) new-spec)
643 ;; This spec. list already exists. Remove old method from dependents
644 (remove-method-in-classes! (car l))
649 (define (internal-add-method! gf m)
650 (slot-set! m 'generic-function gf)
651 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
652 (let ((specializers (slot-ref m 'specializers)))
653 (slot-set! gf 'n-specialized
654 (max (length* specializers)
655 (slot-ref gf 'n-specialized))))
656 (%invalidate-method-cache! gf)
657 (add-method-in-classes! m)
660 (define-generic add-method!)
662 (internal-add-method! add-method!
664 #:specializers (list <generic> <method>)
665 #:procedure internal-add-method!))
667 (define-method (add-method! (proc <procedure>) (m <method>))
668 (if (generic-capability? proc)
670 (enable-primitive-generic! proc)
671 (add-method! proc m))
674 (define-method (add-method! (pg <primitive-generic>) (m <method>))
675 (add-method! (primitive-generic-generic pg) m))
677 (define-method (add-method! obj (m <method>))
678 (goops-error "~S is not a valid generic function" obj))
681 ;;; {Access to meta objects}
687 (define-method (method-source (m <method>))
688 (let* ((spec (map* class-name (slot-ref m 'specializers)))
689 (proc (procedure-source (slot-ref m 'procedure)))
693 (cons (map* list args spec)
699 (define slot-definition-name car)
701 (define slot-definition-options cdr)
703 (define (slot-definition-allocation s)
704 (get-keyword #:allocation (cdr s) #:instance))
706 (define (slot-definition-getter s)
707 (get-keyword #:getter (cdr s) #f))
709 (define (slot-definition-setter s)
710 (get-keyword #:setter (cdr s) #f))
712 (define (slot-definition-accessor s)
713 (get-keyword #:accessor (cdr s) #f))
715 (define (slot-definition-init-value s)
716 ;; can be #f, so we can't use #f as non-value
717 (get-keyword #:init-value (cdr s) (make-unbound)))
719 (define (slot-definition-init-form s)
720 (get-keyword #:init-form (cdr s) (make-unbound)))
722 (define (slot-definition-init-thunk s)
723 (get-keyword #:init-thunk (cdr s) #f))
725 (define (slot-definition-init-keyword s)
726 (get-keyword #:init-keyword (cdr s) #f))
728 (define (class-slot-definition class slot-name)
729 (assq slot-name (class-slots class)))
731 (define (slot-init-function class slot-name)
732 (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
736 ;;; {Standard methods used by the C runtime}
739 ;;; Methods to compare objects
742 (define-method (equal? x y) #f)
744 (define-method (object-eqv? x y) #f)
745 (define-method (object-equal? x y) (eqv? x y))
748 ;;; methods to display/write an object
751 ; Code for writing objects must test that the slots they use are
752 ; bound. Otherwise a slot-unbound method will be called and will
753 ; conduct to an infinite loop.
756 (define (display-address o file)
757 (display (number->string (object-address o) 16) file))
759 (define-method (write o file)
760 (display "#<instance " file)
761 (display-address o file)
764 (define write-object (primitive-generic-generic write))
766 (define-method (write (o <object>) file)
767 (let ((class (class-of o)))
768 (if (slot-bound? class 'name)
771 (display (class-name class) file)
772 (display #\space file)
773 (display-address o file)
777 (define-method (write (o <foreign-object>) file)
778 (let ((class (class-of o)))
779 (if (slot-bound? class 'name)
781 (display "#<foreign-object " file)
782 (display (class-name class) file)
783 (display #\space file)
784 (display-address o file)
788 (define-method (write (class <class>) file)
789 (let ((meta (class-of class)))
790 (if (and (slot-bound? class 'name)
791 (slot-bound? meta 'name))
794 (display (class-name meta) file)
795 (display #\space file)
796 (display (class-name class) file)
797 (display #\space file)
798 (display-address class file)
802 (define-method (write (gf <generic>) file)
803 (let ((meta (class-of gf)))
804 (if (and (slot-bound? meta 'name)
805 (slot-bound? gf 'methods))
808 (display (class-name meta) file)
809 (let ((name (generic-function-name gf)))
812 (display #\space file)
813 (display name file))))
815 (display (length (generic-function-methods gf)) file)
819 (define-method (write (o <method>) file)
820 (let ((meta (class-of o)))
821 (if (and (slot-bound? meta 'name)
822 (slot-bound? o 'specializers))
825 (display (class-name meta) file)
826 (display #\space file)
827 (display (map* (lambda (spec)
828 (if (slot-bound? spec 'name)
829 (slot-ref spec 'name)
831 (method-specializers o))
833 (display #\space file)
834 (display-address o file)
838 ;; Display (do the same thing as write by default)
839 (define-method (display o file)
840 (write-object o file))
843 ;;; Handling of duplicate bindings in the module system
846 (define-method (merge-generics (module <module>)
856 (define-method (merge-generics (module <module>)
864 (and (not (eq? val1 val2))
865 (make-variable (make-extended-generic (list val2 val1) name))))
867 (define-method (merge-generics (module <module>)
874 (gf <extended-generic>))
875 (and (not (memq val2 (slot-ref gf 'extends)))
879 (cons val2 (delq! val2 (slot-ref gf 'extends))))
882 (cons gf (delq! gf (slot-ref val2 'extended-by))))
885 (module-define! duplicate-handlers 'merge-generics merge-generics)
887 (define-method (merge-accessors (module <module>)
897 (define-method (merge-accessors (module <module>)
905 (merge-generics module name int1 val1 int2 val2 var val))
907 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
913 (define (class-slot-g-n-s class slot-name)
914 (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
915 (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
916 (slot-missing class slot-name)))))
917 (if (not (memq (slot-definition-allocation this-slot)
918 '(#:class #:each-subclass)))
919 (slot-missing class slot-name))
922 (define (class-slot-ref class slot)
923 (let ((x ((car (class-slot-g-n-s class slot)) #f)))
925 (slot-unbound class slot)
928 (define (class-slot-set! class slot value)
929 ((cadr (class-slot-g-n-s class slot)) #f value))
931 (define-method (slot-unbound (c <class>) (o <object>) s)
932 (goops-error "Slot `~S' is unbound in object ~S" s o))
934 (define-method (slot-unbound (c <class>) s)
935 (goops-error "Slot `~S' is unbound in class ~S" s c))
937 (define-method (slot-unbound (o <object>))
938 (goops-error "Unbound slot in object ~S" o))
940 (define-method (slot-missing (c <class>) (o <object>) s)
941 (goops-error "No slot with name `~S' in object ~S" s o))
943 (define-method (slot-missing (c <class>) s)
944 (goops-error "No class slot with name `~S' in class ~S" s c))
947 (define-method (slot-missing (c <class>) (o <object>) s value)
948 (slot-missing c o s))
950 ;;; Methods for the possible error we can encounter when calling a gf
952 (define-method (no-next-method (gf <generic>) args)
953 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
955 (define-method (no-applicable-method (gf <generic>) args)
956 (goops-error "No applicable method for ~S in call ~S"
957 gf (cons (generic-function-name gf) args)))
959 (define-method (no-method (gf <generic>) args)
960 (goops-error "No method defined for ~S" gf))
963 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
966 (define-method (shallow-clone (self <object>))
967 (let ((clone (%allocate-instance (class-of self) '()))
968 (slots (map slot-definition-name
969 (class-slots (class-of self)))))
970 (for-each (lambda (slot)
971 (if (slot-bound? self slot)
972 (slot-set! clone slot (slot-ref self slot))))
976 (define-method (deep-clone (self <object>))
977 (let ((clone (%allocate-instance (class-of self) '()))
978 (slots (map slot-definition-name
979 (class-slots (class-of self)))))
980 (for-each (lambda (slot)
981 (if (slot-bound? self slot)
982 (slot-set! clone slot
983 (let ((value (slot-ref self slot)))
984 (if (instance? value)
991 ;;; {Class redefinition utilities}
994 ;;; (class-redefinition OLD NEW)
997 ;;; Has correct the following conditions:
1001 ;;; 1. New accessor specializers refer to new header
1005 ;;; 1. New class cpl refers to the new class header
1006 ;;; 2. Old class header exists on old super classes direct-subclass lists
1007 ;;; 3. New class header exists on new super classes direct-subclass lists
1009 (define-method (class-redefinition (old <class>) (new <class>))
1010 ;; Work on direct methods:
1011 ;; 1. Remove accessor methods from the old class
1012 ;; 2. Patch the occurences of new in the specializers by old
1013 ;; 3. Displace the methods from old to new
1014 (remove-class-accessors! old) ;; -1-
1015 (let ((methods (class-direct-methods new)))
1016 (for-each (lambda (m)
1017 (update-direct-method! m new old)) ;; -2-
1021 (append methods (class-direct-methods old))))
1023 ;; Substitute old for new in new cpl
1024 (set-car! (slot-ref new 'cpl) old)
1026 ;; Remove the old class from the direct-subclasses list of its super classes
1027 (for-each (lambda (c) (slot-set! c 'direct-subclasses
1028 (delv! old (class-direct-subclasses c))))
1029 (class-direct-supers old))
1031 ;; Replace the new class with the old in the direct-subclasses of the supers
1032 (for-each (lambda (c)
1033 (slot-set! c 'direct-subclasses
1034 (cons old (delv! new (class-direct-subclasses c)))))
1035 (class-direct-supers new))
1037 ;; Swap object headers
1038 (%modify-class old new)
1042 ;; Redefine all the subclasses of old to take into account modification
1045 (update-direct-subclass! c new old))
1046 (class-direct-subclasses new))
1048 ;; Invalidate class so that subsequent instances slot accesses invoke
1049 ;; change-object-class
1050 (slot-set! new 'redefined old)
1051 (%invalidate-class new) ;must come after slot-set!
1056 ;;; remove-class-accessors!
1059 (define-method (remove-class-accessors! (c <class>))
1060 (for-each (lambda (m)
1061 (if (is-a? m <accessor-method>)
1062 (remove-method-in-classes! m)))
1063 (class-direct-methods c)))
1066 ;;; update-direct-method!
1069 (define-method (update-direct-method! (m <method>)
1072 (let loop ((l (method-specializers m)))
1073 ;; Note: the <top> in dotted list is never used.
1074 ;; So we can work as if we had only proper lists.
1077 (if (eqv? (car l) old)
1082 ;;; update-direct-subclass!
1085 (define-method (update-direct-subclass! (c <class>)
1088 (class-redefinition c
1089 (make-class (class-direct-supers c)
1090 (class-direct-slots c)
1091 #:name (class-name c)
1092 #:environment (slot-ref c 'environment)
1093 #:metaclass (class-of c))))
1096 ;;; {Utilities for INITIALIZE methods}
1099 ;;; compute-slot-accessors
1101 (define (compute-slot-accessors class slots env)
1104 (let ((name (slot-definition-name s))
1105 (getter-function (slot-definition-getter s))
1106 (setter-function (slot-definition-setter s))
1107 (accessor (slot-definition-accessor s)))
1109 (add-method! getter-function
1110 (compute-getter-method class g-n-s)))
1112 (add-method! setter-function
1113 (compute-setter-method class g-n-s)))
1116 (add-method! accessor
1117 (compute-getter-method class g-n-s))
1118 (add-method! (setter accessor)
1119 (compute-setter-method class g-n-s))))))
1120 slots (slot-ref class 'getters-n-setters)))
1122 (define-method (compute-getter-method (class <class>) slotdef)
1123 (let ((init-thunk (cadr slotdef))
1124 (g-n-s (cddr slotdef)))
1125 (make <accessor-method>
1126 #:specializers (list class)
1127 #:procedure (cond ((pair? g-n-s)
1130 (make-generic-bound-check-getter (car g-n-s))
1133 (standard-get g-n-s))
1135 (bound-check-get g-n-s)))
1136 #:slot-definition slotdef)))
1138 (define-method (compute-setter-method (class <class>) slotdef)
1139 (let ((g-n-s (cddr slotdef)))
1140 (make <accessor-method>
1141 #:specializers (list class <top>)
1142 #:procedure (if (pair? g-n-s)
1144 (standard-set g-n-s))
1145 #:slot-definition slotdef)))
1147 (define (make-generic-bound-check-getter proc)
1148 (let ((source (and (closure? proc) (procedure-source proc))))
1149 (if (and source (null? (cdddr source)))
1150 (let ((obj (caadr source)))
1151 ;; smart closure compilation
1153 `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
1154 (procedure-environment proc)))
1155 (lambda (o) (assert-bound (proc o) o)))))
1157 (define n-standard-accessor-methods 10)
1159 (define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
1160 (define standard-get-methods (make-vector n-standard-accessor-methods #f))
1161 (define standard-set-methods (make-vector n-standard-accessor-methods #f))
1163 (define (standard-accessor-method make methods)
1165 (cond ((>= index n-standard-accessor-methods) (make index))
1166 ((vector-ref methods index))
1167 (else (let ((m (make index)))
1168 (vector-set! methods index m)
1171 (define (make-bound-check-get index)
1172 (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
1174 (define (make-get index)
1175 (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
1177 (define (make-set index)
1178 (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
1180 (define bound-check-get
1181 (standard-accessor-method make-bound-check-get bound-check-get-methods))
1182 (define standard-get (standard-accessor-method make-get standard-get-methods))
1183 (define standard-set (standard-accessor-method make-set standard-set-methods))
1185 ;;; compute-getters-n-setters
1187 (define (compute-getters-n-setters class slots env)
1189 (define (compute-slot-init-function s)
1190 (or (slot-definition-init-thunk s)
1191 (let ((init (slot-definition-init-value s)))
1192 (and (not (unbound? init))
1193 (lambda () init)))))
1195 (define (verify-accessors slot l)
1199 (if (not (and (closure? get)
1200 (= (car (procedure-property get 'arity)) 1)))
1201 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1203 (if (not (and (closure? set)
1204 (= (car (procedure-property set 'arity)) 2)))
1205 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1209 (let* ((g-n-s (compute-get-n-set class s))
1210 (name (slot-definition-name s)))
1211 ; For each slot we have '(name init-function getter setter)
1212 ; If slot, we have the simplest form '(name init-function . index)
1213 (verify-accessors name g-n-s)
1215 (cons (compute-slot-init-function s)
1221 ;;; Correct behaviour:
1223 ;;; (define-class food ())
1224 ;;; (define-class fruit (food))
1225 ;;; (define-class spice (food))
1226 ;;; (define-class apple (fruit))
1227 ;;; (define-class cinnamon (spice))
1228 ;;; (define-class pie (apple cinnamon))
1229 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1231 ;;; (define-class d ())
1232 ;;; (define-class e ())
1233 ;;; (define-class f ())
1234 ;;; (define-class b (d e))
1235 ;;; (define-class c (e f))
1236 ;;; (define-class a (b c))
1237 ;;; => cpl (a) = a b d c e f object top
1240 (define-method (compute-cpl (class <class>))
1241 (compute-std-cpl class class-direct-supers))
1245 (define (only-non-null lst)
1246 (filter (lambda (l) (not (null? l))) lst))
1248 (define (compute-std-cpl c get-direct-supers)
1249 (let ((c-direct-supers (get-direct-supers c)))
1250 (merge-lists (list c)
1251 (only-non-null (append (map class-precedence-list
1253 (list c-direct-supers))))))
1255 (define (merge-lists reversed-partial-result inputs)
1257 ((every null? inputs)
1258 (reverse! reversed-partial-result))
1260 (let* ((candidate (lambda (c)
1261 (and (not (any (lambda (l)
1265 (candidate-car (lambda (l)
1266 (and (not (null? l))
1267 (candidate (car l)))))
1268 (next (any candidate-car inputs)))
1270 (goops-error "merge-lists: Inconsistent precedence graph"))
1271 (let ((remove-next (lambda (l)
1272 (if (eq? (car l) next)
1275 (merge-lists (cons next reversed-partial-result)
1276 (only-non-null (map remove-next inputs))))))))
1278 ;; Modified from TinyClos:
1280 ;; A simple topological sort.
1282 ;; It's in this file so that both TinyClos and Objects can use it.
1284 ;; This is a fairly modified version of code I originally got from Anurag
1285 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1288 (define (compute-clos-cpl c get-direct-supers)
1289 (top-sort ((build-transitive-closure get-direct-supers) c)
1290 ((build-constraints get-direct-supers) c)
1291 (std-tie-breaker get-direct-supers)))
1294 (define (top-sort elements constraints tie-breaker)
1295 (let loop ((elements elements)
1296 (constraints constraints)
1298 (if (null? elements)
1300 (let ((can-go-in-now
1303 (every (lambda (constraint)
1304 (or (not (eq? (cadr constraint) x))
1305 (memq (car constraint) result)))
1308 (if (null? can-go-in-now)
1309 (goops-error "top-sort: Invalid constraints")
1310 (let ((choice (if (null? (cdr can-go-in-now))
1315 (filter (lambda (x) (not (eq? x choice)))
1318 (append result (list choice)))))))))
1320 (define (std-tie-breaker get-supers)
1321 (lambda (partial-cpl min-elts)
1322 (let loop ((pcpl (reverse partial-cpl)))
1323 (let ((current-elt (car pcpl)))
1324 (let ((ds-of-ce (get-supers current-elt)))
1325 (let ((common (filter (lambda (x)
1329 (if (null? (cdr pcpl))
1330 (goops-error "std-tie-breaker: Nothing valid")
1335 (define (build-transitive-closure get-follow-ons)
1337 (let track ((result '())
1341 (let ((next (car pending)))
1342 (if (memq next result)
1343 (track result (cdr pending))
1344 (track (cons next result)
1345 (append (get-follow-ons next)
1346 (cdr pending)))))))))
1348 (define (build-constraints get-follow-ons)
1350 (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1353 (if (or (null? this-one) (null? (cdr this-one)))
1354 (if (null? elements)
1356 (loop (cdr elements)
1357 (cons (car elements)
1358 (get-follow-ons (car elements)))
1362 (cons (list (car this-one) (cadr this-one))
1365 ;;; compute-get-n-set
1367 (define-method (compute-get-n-set (class <class>) s)
1368 (case (slot-definition-allocation s)
1369 ((#:instance) ;; Instance slot
1370 ;; get-n-set is just its offset
1371 (let ((already-allocated (slot-ref class 'nfields)))
1372 (slot-set! class 'nfields (+ already-allocated 1))
1375 ((#:class) ;; Class slot
1376 ;; Class-slots accessors are implemented as 2 closures around
1377 ;; a Scheme variable. As instance slots, class slots must be
1378 ;; unbound at init time.
1379 (let ((name (slot-definition-name s)))
1380 (if (memq name (map slot-definition-name (class-direct-slots class)))
1381 ;; This slot is direct; create a new shared variable
1382 (make-closure-variable class)
1383 ;; Slot is inherited. Find its definition in superclass
1384 (let loop ((l (cdr (class-precedence-list class))))
1385 (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1388 (loop (cdr l))))))))
1390 ((#:each-subclass) ;; slot shared by instances of direct subclass.
1391 ;; (Thomas Buerger, April 1998)
1392 (make-closure-variable class))
1394 ((#:virtual) ;; No allocation
1395 ;; slot-ref and slot-set! function must be given by the user
1396 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
1397 (set (get-keyword #:slot-set! (slot-definition-options s) #f))
1398 (env (class-environment class)))
1399 (if (not (and get set))
1400 (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
1403 (else (next-method))))
1405 (define (make-closure-variable class)
1406 (let ((shared-variable (make-unbound)))
1407 (list (lambda (o) shared-variable)
1408 (lambda (o v) (set! shared-variable v)))))
1410 (define-method (compute-get-n-set (o <object>) s)
1411 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1413 (define-method (compute-slots (class <class>))
1414 (%compute-slots class))
1420 (define-method (initialize (object <object>) initargs)
1421 (%initialize-object object initargs))
1423 (define-method (initialize (class <class>) initargs)
1425 (let ((dslots (get-keyword #:slots initargs '()))
1426 (supers (get-keyword #:dsupers initargs '()))
1427 (env (get-keyword #:environment initargs (top-level-env))))
1429 (slot-set! class 'name (get-keyword #:name initargs '???))
1430 (slot-set! class 'direct-supers supers)
1431 (slot-set! class 'direct-slots dslots)
1432 (slot-set! class 'direct-subclasses '())
1433 (slot-set! class 'direct-methods '())
1434 (slot-set! class 'cpl (compute-cpl class))
1435 (slot-set! class 'redefined #f)
1436 (slot-set! class 'environment env)
1437 (let ((slots (compute-slots class)))
1438 (slot-set! class 'slots slots)
1439 (slot-set! class 'nfields 0)
1440 (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1443 ;; Build getters - setters - accessors
1444 (compute-slot-accessors class slots env))
1446 ;; Update the "direct-subclasses" of each inherited classes
1447 (for-each (lambda (x)
1450 (cons class (slot-ref x 'direct-subclasses))))
1453 ;; Support for the underlying structs:
1455 ;; Inherit class flags (invisible on scheme level) from supers
1456 (%inherit-magic! class supers)
1458 ;; Set the layout slot
1459 (%prep-layout! class)))
1461 (define (initialize-object-procedure object initargs)
1462 (let ((proc (get-keyword #:procedure initargs #f)))
1465 (apply set-object-procedure! object proc))
1466 ((valid-object-procedure? proc)
1467 (set-object-procedure! object proc))
1469 (set-object-procedure! object
1470 (lambda args (apply proc args)))))))
1472 (define-method (initialize (class <operator-class>) initargs)
1474 (initialize-object-procedure class initargs))
1476 (define-method (initialize (owsc <operator-with-setter-class>) initargs)
1478 (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1480 (define-method (initialize (entity <entity>) initargs)
1482 (initialize-object-procedure entity initargs))
1484 (define-method (initialize (ews <entity-with-setter>) initargs)
1486 (%set-object-setter! ews (get-keyword #:setter initargs #f)))
1488 (define-method (initialize (generic <generic>) initargs)
1489 (let ((previous-definition (get-keyword #:default initargs #f))
1490 (name (get-keyword #:name initargs #f)))
1492 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1493 (list (make <method>
1494 #:specializers <top>
1497 (apply previous-definition
1501 (set-procedure-property! generic 'name name))
1504 (define-method (initialize (eg <extended-generic>) initargs)
1506 (slot-set! eg 'extends (get-keyword #:extends initargs '())))
1508 (define dummy-procedure (lambda args *unspecified*))
1510 (define-method (initialize (method <method>) initargs)
1512 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1513 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1514 (slot-set! method 'procedure
1515 (get-keyword #:procedure initargs dummy-procedure))
1516 (slot-set! method 'code-table '()))
1518 (define-method (initialize (obj <foreign-object>) initargs))
1524 (define (change-object-class old-instance old-class new-class)
1525 (let ((new-instance (allocate-instance new-class '())))
1526 ;; Initalize the slot of the new instance
1527 (for-each (lambda (slot)
1528 (if (and (slot-exists-using-class? old-class old-instance slot)
1529 (eq? (slot-definition-allocation
1530 (class-slot-definition old-class slot))
1532 (slot-bound-using-class? old-class old-instance slot))
1533 ;; Slot was present and allocated in old instance; copy it
1534 (slot-set-using-class!
1538 (slot-ref-using-class old-class old-instance slot))
1539 ;; slot was absent; initialize it with its default value
1540 (let ((init (slot-init-function new-class slot)))
1542 (slot-set-using-class!
1546 (apply init '()))))))
1547 (map slot-definition-name (class-slots new-class)))
1548 ;; Exchange old and new instance in place to keep pointers valid
1549 (%modify-instance old-instance new-instance)
1550 ;; Allow class specific updates of instances (which now are swapped)
1551 (update-instance-for-different-class new-instance old-instance)
1555 (define-method (update-instance-for-different-class (old-instance <object>)
1558 ;;not really important what we do, we just need a default method
1561 (define-method (change-class (old-instance <object>) (new-class <class>))
1562 (change-object-class old-instance (class-of old-instance) new-class))
1567 ;;; A new definition which overwrites the previous one which was built-in
1570 (define-method (allocate-instance (class <class>) initargs)
1571 (%allocate-instance class initargs))
1573 (define-method (make-instance (class <class>) . initargs)
1574 (let ((instance (allocate-instance class initargs)))
1575 (initialize instance initargs)
1578 (define make make-instance)
1583 ;;; Protocol for calling standard generic functions. This protocol is
1584 ;;; not used for real <generic> functions (in this case we use a
1585 ;;; completely C hard-coded protocol). Apply-generic is used by
1586 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1587 ;;; The code below is similar to the first MOP described in AMOP. In
1588 ;;; particular, it doesn't used the currified approach to gf
1589 ;;; call. There are 2 reasons for that:
1590 ;;; - the protocol below is exposed to mimic completely the one written in C
1591 ;;; - the currified protocol would be imho inefficient in C.
1594 (define-method (apply-generic (gf <generic>) args)
1595 (if (null? (slot-ref gf 'methods))
1596 (no-method gf args))
1597 (let ((methods (compute-applicable-methods gf args)))
1599 (apply-methods gf (sort-applicable-methods gf methods args) args)
1600 (no-applicable-method gf args))))
1602 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1604 (define %%compute-applicable-methods
1605 (make <generic> #:name 'compute-applicable-methods))
1607 (define-method (%%compute-applicable-methods (gf <generic>) args)
1608 (%compute-applicable-methods gf args))
1610 (set! compute-applicable-methods %%compute-applicable-methods)
1612 (define-method (sort-applicable-methods (gf <generic>) methods args)
1613 (let ((targs (map class-of args)))
1614 (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1616 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1617 (%method-more-specific? m1 m2 targs))
1619 (define-method (apply-method (gf <generic>) methods build-next args)
1620 (apply (method-procedure (car methods))
1621 (build-next (cdr methods) args)
1624 (define-method (apply-methods (gf <generic>) (l <list>) args)
1625 (letrec ((next (lambda (procs args)
1627 (let ((a (if (null? new-args) args new-args)))
1629 (no-next-method gf a)
1630 (apply-method gf procs next a)))))))
1631 (apply-method gf l next args)))
1633 ;; We don't want the following procedure to turn up in backtraces:
1634 (for-each (lambda (proc)
1635 (set-procedure-property! proc 'system-procedure #t))
1639 no-applicable-method
1644 ;;; {<composite-metaclass> and <active-metaclass>}
1647 ;(autoload "active-slot" <active-metaclass>)
1648 ;(autoload "composite-slot" <composite-metaclass>)
1649 ;(export <composite-metaclass> <active-metaclass>)
1657 ;; duplicate the standard list->set function but using eq instead of
1658 ;; eqv which really sucks a lot, uselessly here
1660 (define (list2set l)
1665 ((memq (car l) res) (loop (cdr l) res))
1666 (else (loop (cdr l) (cons (car l) res))))))
1668 (define (class-subclasses c)
1669 (letrec ((allsubs (lambda (c)
1670 (cons c (mapappend allsubs
1671 (class-direct-subclasses c))))))
1672 (list2set (cdr (allsubs c)))))
1674 (define (class-methods c)
1675 (list2set (mapappend class-direct-methods
1676 (cons c (class-subclasses c)))))
1679 ;;; {Final initialization}
1682 ;; Tell C code that the main bulk of Goops has been loaded