| blob | b8f63ff275f0efcdf112530f70a65cc16dae9963 |
1 ;;; installed-scm-file
3 ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
4 ;;;;
5 ;;;; This program is free software; you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation; either version 2, or (at your option)
8 ;;;; any later version.
9 ;;;;
10 ;;;; This program 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
13 ;;;; GNU General Public License for more details.
14 ;;;;
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;;;; Boston, MA 02111-1307 USA
19 ;;;;
20 ;;;; As a special exception, the Free Software Foundation gives permission
21 ;;;; for additional uses of the text contained in its release of GUILE.
22 ;;;;
23 ;;;; The exception is that, if you link the GUILE library with other files
24 ;;;; to produce an executable, this does not by itself cause the
25 ;;;; resulting executable to be covered by the GNU General Public License.
26 ;;;; Your use of that executable is in no way restricted on account of
27 ;;;; linking the GUILE library code into it.
28 ;;;;
29 ;;;; This exception does not however invalidate any other reasons why
30 ;;;; the executable file might be covered by the GNU General Public License.
31 ;;;;
32 ;;;; This exception applies only to the code released by the
33 ;;;; Free Software Foundation under the name GUILE. If you copy
34 ;;;; code from other Free Software Foundation releases into a copy of
35 ;;;; GUILE, as the General Public License permits, the exception does
36 ;;;; not apply to the code that you add in this way. To avoid misleading
37 ;;;; anyone as to the status of such modified files, you must delete
38 ;;;; this exception notice from them.
39 ;;;;
40 ;;;; If you write modifications of your own for GUILE, it is your choice
41 ;;;; whether to permit this exception to apply to your modifications.
42 ;;;; If you do not wish that, delete this exception notice.
43 ;;;;
44 \f
46 ;;;; This software is a derivative work of other copyrighted softwares; the
47 ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
48 ;;;;
49 ;;;; This file is based upon stklos.stk from the STk distribution by
50 ;;;; Erick Gallesio <eg@unice.fr>.
51 ;;;;
53 (define-module (oop goops)
54 :export-syntax (define-class class
55 define-generic define-accessor define-method
56 method)
57 :export (goops-version is-a?
58 ensure-metaclass ensure-metaclass-with-supers
59 make-class
60 make-generic ensure-generic
61 make-accessor ensure-accessor
62 make-method add-method!
63 object-eqv? object-equal?
64 class-slot-ref class-slot-set! slot-unbound slot-missing
65 slot-definition-name slot-definition-options
66 slot-definition-allocation
67 slot-definition-getter slot-definition-setter
68 slot-definition-accessor
69 slot-definition-init-value slot-definition-init-form
70 slot-definition-init-thunk slot-definition-init-keyword
71 slot-init-function class-slot-definition
72 method-source
73 compute-cpl compute-std-cpl compute-get-n-set compute-slots
74 compute-getter-method compute-setter-method
75 allocate-instance initialize make-instance make
76 no-next-method no-applicable-method no-method
77 change-class update-instance-for-different-class
78 shallow-clone deep-clone
79 class-redefinition
80 apply-generic apply-method apply-methods
81 compute-applicable-methods %compute-applicable-methods
82 method-more-specific? sort-applicable-methods
83 class-subclasses class-methods
84 goops-error
85 min-fixnum max-fixnum
86 ;;; *fixme* Should go into goops.c
87 instance? slot-ref-using-class
88 slot-set-using-class! slot-bound-using-class?
89 slot-exists-using-class? slot-ref slot-set! slot-bound?
90 class-name class-direct-supers class-direct-subclasses
91 class-direct-methods class-direct-slots class-precedence-list
92 class-slots class-environment
93 generic-function-name
94 generic-function-methods method-generic-function method-specializers
95 primitive-generic-generic enable-primitive-generic!
96 method-procedure accessor-method-slot-definition
97 slot-exists? make find-method get-keyword)
98 :re-export (class-of) ;; from (guile)
99 :no-backtrace)
101 ;; First initialize the builtin part of GOOPS
102 (%init-goops-builtins)
104 ;; Then load the rest of GOOPS
105 (use-modules (oop goops util)
106 (oop goops dispatch)
107 (oop goops compile))
109 \f
110 (define min-fixnum (- (expt 2 29)))
112 (define max-fixnum (- (expt 2 29) 1))
114 ;;
115 ;; goops-error
116 ;;
117 (define (goops-error format-string . args)
118 (save-stack)
119 (scm-error 'goops-error #f format-string args '()))
121 ;;
122 ;; is-a?
123 ;;
124 (define (is-a? obj class)
125 (and (memq class (class-precedence-list (class-of obj))) #t))
128 ;;;
129 ;;; {Meta classes}
130 ;;;
132 (define ensure-metaclass-with-supers
133 (let ((table-of-metas '()))
134 (lambda (meta-supers)
135 (let ((entry (assoc meta-supers table-of-metas)))
136 (if entry
137 ;; Found a previously created metaclass
138 (cdr entry)
139 ;; Create a new meta-class which inherit from "meta-supers"
140 (let ((new (make <class> #:dsupers meta-supers
141 #:slots '()
142 #:name (gensym "metaclass"))))
143 (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
144 new))))))
146 (define (ensure-metaclass supers env)
147 (if (null? supers)
148 <class>
149 (let* ((all-metas (map (lambda (x) (class-of x)) supers))
150 (all-cpls (apply append
151 (map (lambda (m)
152 (cdr (class-precedence-list m)))
153 all-metas)))
154 (needed-metas '()))
155 ;; Find the most specific metaclasses. The new metaclass will be
156 ;; a subclass of these.
157 (for-each
158 (lambda (meta)
159 (if (and (not (member meta all-cpls))
160 (not (member meta needed-metas)))
161 (set! needed-metas (append needed-metas (list meta)))))
162 all-metas)
163 ;; Now return a subclass of the metaclasses we found.
164 (if (null? (cdr needed-metas))
165 (car needed-metas) ; If there's only one, just use it.
166 (ensure-metaclass-with-supers needed-metas)))))
168 ;;;
169 ;;; {Classes}
170 ;;;
172 ;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
173 ;;;
174 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
175 ;;; OPTION ::= KEYWORD VALUE
176 ;;;
177 (define (define-class-pre-definition keyword exp env)
178 (case keyword
179 ((#:getter #:setter)
180 (if (defined? exp env)
181 `(define ,exp (ensure-generic ,exp ',exp))
182 `(define ,exp (make-generic ',exp))))
183 ((#:accessor)
184 (if (defined? exp env)
185 `(define ,exp (ensure-accessor ,exp ',exp))
186 `(define ,exp (make-accessor ',exp))))
187 (else #f)))
189 ;;; This code should be implemented in C.
190 ;;;
191 (define define-class
192 (letrec (;; Some slot options require extra definitions to be made.
193 ;; In particular, we want to make sure that the generic
194 ;; function objects which represent accessors exist
195 ;; before `make-class' tries to add methods to them.
196 ;;
197 ;; Postpone error handling to class macro.
198 ;;
199 (pre-definitions
200 (lambda (slots env)
201 (do ((slots slots (cdr slots))
202 (definitions '()
203 (if (pair? (car slots))
204 (do ((options (cdar slots) (cddr options))
205 (definitions definitions
206 (cond ((not (symbol? (cadr options)))
207 definitions)
208 ((define-class-pre-definition
209 (car options)
210 (cadr options)
211 env)
212 => (lambda (definition)
213 (cons definition definitions)))
214 (else definitions))))
215 ((not (and (pair? options)
216 (pair? (cdr options))))
217 definitions))
218 definitions)))
219 ((or (not (pair? slots))
220 (keyword? (car slots)))
221 (reverse definitions)))))
223 ;; Syntax
224 (name cadr)
225 (slots cdddr))
227 (procedure->macro
228 (lambda (exp env)
229 (cond ((not (top-level-env? env))
230 (goops-error "define-class: Only allowed at top level"))
231 ((not (and (list? exp) (>= (length exp) 3)))
232 (goops-error "missing or extra expression"))
233 (else
234 (let ((name (name exp)))
235 `(begin
236 ;; define accessors
237 ,@(pre-definitions (slots exp) env)
239 ,(if (defined? name env)
241 ;; redefine an old class
242 `(define ,name
243 (let ((old ,name)
244 (new (class ,@(cddr exp) #:name ',name)))
245 (if (and (is-a? old <class>)
246 ;; Prevent redefinition of non-objects
247 (memq <object>
248 (class-precedence-list old)))
249 (class-redefinition old new)
250 new)))
252 ;; define a new class
253 `(define ,name
254 (class ,@(cddr exp) #:name ',name)))))))))))
256 (define standard-define-class define-class)
258 ;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
259 ;;;
260 ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
261 ;;; OPTION ::= KEYWORD VALUE
262 ;;;
263 (define class
264 (letrec ((slot-option-keyword car)
265 (slot-option-value cadr)
266 (process-slot-options
267 (lambda (options)
268 (let loop ((options options)
269 (res '()))
270 (cond ((null? options)
271 (reverse res))
272 ((null? (cdr options))
273 (goops-error "malformed slot option list"))
274 ((not (keyword? (slot-option-keyword options)))
275 (goops-error "malformed slot option list"))
276 (else
277 (case (slot-option-keyword options)
278 ((#:init-form)
279 (loop (cddr options)
280 (append (list `(lambda ()
281 ,(slot-option-value options))
282 #:init-thunk
283 (list 'quote
284 (slot-option-value options))
285 #:init-form)
286 res)))
287 (else
288 (loop (cddr options)
289 (cons (cadr options)
290 (cons (car options)
291 res)))))))))))
293 (procedure->memoizing-macro
294 (let ((supers cadr)
295 (slots cddr)
296 (options cdddr))
297 (lambda (exp env)
298 (cond ((not (and (list? exp) (>= (length exp) 2)))
299 (goops-error "missing or extra expression"))
300 ((not (list? (supers exp)))
301 (goops-error "malformed superclass list: ~S" (supers exp)))
302 (else
303 (let ((slot-defs (cons #f '())))
304 (do ((slots (slots exp) (cdr slots))
305 (defs slot-defs (cdr defs)))
306 ((or (null? slots)
307 (keyword? (car slots)))
308 `(make-class
309 ;; evaluate super class variables
310 (list ,@(supers exp))
311 ;; evaluate slot definitions, except the slot name!
312 (list ,@(cdr slot-defs))
313 ;; evaluate class options
314 ,@slots
315 ;; place option last in case someone wants to
316 ;; pass a different value
317 #:environment ',env))
318 (set-cdr!
319 defs
320 (list (if (pair? (car slots))
321 `(list ',(slot-definition-name (car slots))
322 ,@(process-slot-options
323 (slot-definition-options
324 (car slots))))
325 `(list ',(car slots))))))))))))))
327 (define (make-class supers slots . options)
328 (let ((env (or (get-keyword #:environment options #f)
329 (top-level-env))))
330 (let* ((name (get-keyword #:name options (make-unbound)))
331 (supers (if (not (or-map (lambda (class)
332 (memq <object>
333 (class-precedence-list class)))
334 supers))
335 (append supers (list <object>))
336 supers))
337 (metaclass (or (get-keyword #:metaclass options #f)
338 (ensure-metaclass supers env))))
340 ;; Verify that all direct slots are different and that we don't inherit
341 ;; several time from the same class
342 (let ((tmp1 (find-duplicate supers))
343 (tmp2 (find-duplicate (map slot-definition-name slots))))
344 (if tmp1
345 (goops-error "make-class: super class ~S is duplicate in class ~S"
346 tmp1 name))
347 (if tmp2
348 (goops-error "make-class: slot ~S is duplicate in class ~S"
349 tmp2 name)))
351 ;; Everything seems correct, build the class
352 (apply make metaclass
353 #:dsupers supers
354 #:slots slots
355 #:name name
356 #:environment env
357 options))))
359 ;;;
360 ;;; {Generic functions and accessors}
361 ;;;
363 (define define-generic
364 (procedure->macro
365 (lambda (exp env)
366 (let ((name (cadr exp)))
367 (cond ((not (symbol? name))
368 (goops-error "bad generic function name: ~S" name))
369 ((defined? name env)
370 `(define ,name
371 (if (is-a? ,name <generic>)
372 (make <generic> #:name ',name)
373 (ensure-generic ,name ',name))))
374 (else
375 `(define ,name (make <generic> #:name ',name))))))))
377 (define (make-generic . name)
378 (let ((name (and (pair? name) (car name))))
379 (make <generic> #:name name)))
381 (define (ensure-generic old-definition . name)
382 (let ((name (and (pair? name) (car name))))
383 (cond ((is-a? old-definition <generic>) old-definition)
384 ((procedure-with-setter? old-definition)
385 (make <generic-with-setter>
386 #:name name
387 #:default (procedure old-definition)
388 #:setter (setter old-definition)))
389 ((procedure? old-definition)
390 (make <generic> #:name name #:default old-definition))
391 (else (make <generic> #:name name)))))
393 (define define-accessor
394 (procedure->macro
395 (lambda (exp env)
396 (let ((name (cadr exp)))
397 (cond ((not (symbol? name))
398 (goops-error "bad accessor name: ~S" name))
399 ((defined? name env)
400 `(define ,name
401 (if (and (is-a? ,name <generic-with-setter>)
402 (is-a? (setter ,name) <generic>))
403 (make-accessor ',name)
404 (ensure-accessor ,name ',name))))
405 (else
406 `(define ,name (make-accessor ',name))))))))
408 (define (make-setter-name name)
409 (string->symbol (string-append "setter:" (symbol->string name))))
411 (define (make-accessor . name)
412 (let ((name (and (pair? name) (car name))))
413 (make <generic-with-setter>
414 #:name name
415 #:setter (make <generic>
416 #:name (and name (make-setter-name name))))))
418 (define (ensure-accessor proc . name)
419 (let ((name (and (pair? name) (car name))))
420 (cond ((is-a? proc <generic-with-setter>)
421 (if (is-a? (setter proc) <generic>)
422 proc
423 (upgrade-generic-with-setter proc (setter proc))))
424 ((is-a? proc <generic>)
425 (upgrade-generic-with-setter proc (make-generic name)))
426 ((procedure-with-setter? proc)
427 (make <generic-with-setter>
428 #:name name
429 #:default (procedure proc)
430 #:setter (ensure-generic (setter proc) name)))
431 ((procedure? proc)
432 (ensure-accessor (ensure-generic proc name) name))
433 (else
434 (make-accessor name)))))
436 (define (upgrade-generic-with-setter generic setter)
437 (let ((methods (generic-function-methods generic))
438 (gws (make <generic-with-setter>
439 #:name (generic-function-name generic)
440 #:setter setter)))
441 ;; Steal old methods
442 (for-each (lambda (method)
443 (slot-set! method 'generic-function gws))
444 methods)
445 (slot-set! gws 'methods methods)
446 gws))
448 ;;;
449 ;;; {Methods}
450 ;;;
452 (define define-method
453 (procedure->memoizing-macro
454 (lambda (exp env)
455 (let ((head (cadr exp)))
456 (if (not (pair? head))
457 (goops-error "bad method head: ~S" head)
458 (let ((gf (car head)))
459 (cond ((and (pair? gf)
460 (eq? (car gf) 'setter)
461 (pair? (cdr gf))
462 (symbol? (cadr gf))
463 (null? (cddr gf)))
464 ;; named setter method
465 (let ((name (cadr gf)))
466 (cond ((not (symbol? name))
467 `(add-method! (setter ,name)
468 (method ,(cdadr exp)
469 ,@(cddr exp))))
470 ((defined? name env)
471 `(begin
472 ;; *fixme* Temporary hack for the current
473 ;; module system
474 (if (not ,name)
475 (define-accessor ,name))
476 (add-method! (setter ,name)
477 (method ,(cdadr exp)
478 ,@(cddr exp)))))
479 (else
480 `(begin
481 (define-accessor ,name)
482 (add-method! (setter ,name)
483 (method ,(cdadr exp)
484 ,@(cddr exp))))))))
485 ((not (symbol? gf))
486 `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
487 ((defined? gf env)
488 `(begin
489 ;; *fixme* Temporary hack for the current
490 ;; module system
491 (if (not ,gf)
492 (define-generic ,gf))
493 (add-method! ,gf
494 (method ,(cdadr exp)
495 ,@(cddr exp)))))
496 (else
497 `(begin
498 (define-generic ,gf)
499 (add-method! ,gf
500 (method ,(cdadr exp)
501 ,@(cddr exp))))))))))))
503 (define (make-method specializers procedure)
504 (make <method>
505 #:specializers specializers
506 #:procedure procedure))
508 (define method
509 (letrec ((specializers
510 (lambda (ls)
511 (cond ((null? ls) '('()))
512 ((pair? ls) (cons (if (pair? (car ls))
513 (cadar ls)
514 '<top>)
515 (specializers (cdr ls))))
516 (else '(<top>)))))
517 (formals
518 (lambda (ls)
519 (if (pair? ls)
520 (cons (if (pair? (car ls)) (caar ls) (car ls))
521 (formals (cdr ls)))
522 ls))))
523 (procedure->memoizing-macro
524 (lambda (exp env)
525 (let ((args (cadr exp))
526 (body (cddr exp)))
527 `(make <method>
528 #:specializers (cons* ,@(specializers args))
529 #:procedure (lambda ,(formals args)
530 ,@(if (null? body)
531 (list *unspecified*)
532 body))))))))
534 ;;;
535 ;;; {add-method!}
536 ;;;
538 (define (add-method-in-classes! m)
539 ;; Add method in all the classes which appears in its specializers list
540 (for-each* (lambda (x)
541 (let ((dm (class-direct-methods x)))
542 (if (not (memv m dm))
543 (slot-set! x 'direct-methods (cons m dm)))))
544 (method-specializers m)))
546 (define (remove-method-in-classes! m)
547 ;; Remove method in all the classes which appears in its specializers list
548 (for-each* (lambda (x)
549 (slot-set! x
550 'direct-methods
551 (delv! m (class-direct-methods x))))
552 (method-specializers m)))
554 (define (compute-new-list-of-methods gf new)
555 (let ((new-spec (method-specializers new))
556 (methods (generic-function-methods gf)))
557 (let loop ((l methods))
558 (if (null? l)
559 (cons new methods)
560 (if (equal? (method-specializers (car l)) new-spec)
561 (begin
562 ;; This spec. list already exists. Remove old method from dependents
563 (remove-method-in-classes! (car l))
564 (set-car! l new)
565 methods)
566 (loop (cdr l)))))))
568 (define (internal-add-method! gf m)
569 (slot-set! m 'generic-function gf)
570 (slot-set! gf 'methods (compute-new-list-of-methods gf m))
571 (let ((specializers (slot-ref m 'specializers)))
572 (slot-set! gf 'n-specialized
573 (max (length* specializers)
574 (slot-ref gf 'n-specialized))))
575 (%invalidate-method-cache! gf)
576 (add-method-in-classes! m)
577 *unspecified*)
579 (define-generic add-method!)
581 (internal-add-method! add-method!
582 (make <method>
583 #:specializers (list <generic> <method>)
584 #:procedure internal-add-method!))
586 (define-method (add-method! (proc <procedure>) (m <method>))
587 (if (generic-capability? proc)
588 (begin
589 (enable-primitive-generic! proc)
590 (add-method! proc m))
591 (next-method)))
593 (define-method (add-method! (pg <primitive-generic>) (m <method>))
594 (add-method! (primitive-generic-generic pg) m))
596 (define-method (add-method! obj (m <method>))
597 (goops-error "~S is not a valid generic function" obj))
599 ;;;
600 ;;; {Access to meta objects}
601 ;;;
603 ;;;
604 ;;; Methods
605 ;;;
606 (define-method (method-source (m <method>))
607 (let* ((spec (map* class-name (slot-ref m 'specializers)))
608 (proc (procedure-source (slot-ref m 'procedure)))
609 (args (cadr proc))
610 (body (cddr proc)))
611 (cons 'method
612 (cons (map* list args spec)
613 body))))
615 ;;;
616 ;;; Slots
617 ;;;
618 (define slot-definition-name car)
620 (define slot-definition-options cdr)
622 (define (slot-definition-allocation s)
623 (get-keyword #:allocation (cdr s) #:instance))
625 (define (slot-definition-getter s)
626 (get-keyword #:getter (cdr s) #f))
628 (define (slot-definition-setter s)
629 (get-keyword #:setter (cdr s) #f))
631 (define (slot-definition-accessor s)
632 (get-keyword #:accessor (cdr s) #f))
634 (define (slot-definition-init-value s)
635 ;; can be #f, so we can't use #f as non-value
636 (get-keyword #:init-value (cdr s) (make-unbound)))
638 (define (slot-definition-init-form s)
639 (get-keyword #:init-form (cdr s) (make-unbound)))
641 (define (slot-definition-init-thunk s)
642 (get-keyword #:init-thunk (cdr s) #f))
644 (define (slot-definition-init-keyword s)
645 (get-keyword #:init-keyword (cdr s) #f))
647 (define (class-slot-definition class slot-name)
648 (assq slot-name (class-slots class)))
650 (define (slot-init-function class slot-name)
651 (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
654 ;;;
655 ;;; {Standard methods used by the C runtime}
656 ;;;
658 ;;; Methods to compare objects
659 ;;;
661 (define-method (object-eqv? x y) #f)
662 (define-method (object-equal? x y) (eqv? x y))
664 ;;;
665 ;;; methods to display/write an object
666 ;;;
668 ; Code for writing objects must test that the slots they use are
669 ; bound. Otherwise a slot-unbound method will be called and will
670 ; conduct to an infinite loop.
672 ;; Write
673 (define (display-address o file)
674 (display (number->string (object-address o) 16) file))
676 (define-method (write o file)
677 (display "#<instance " file)
678 (display-address o file)
679 (display #\> file))
681 (define write-object (primitive-generic-generic write))
683 (define-method (write (o <object>) file)
684 (let ((class (class-of o)))
685 (if (slot-bound? class 'name)
686 (begin
687 (display "#<" file)
688 (display (class-name class) file)
689 (display #\space file)
690 (display-address o file)
691 (display #\> file))
692 (next-method))))
694 (define-method (write (o <foreign-object>) file)
695 (let ((class (class-of o)))
696 (if (slot-bound? class 'name)
697 (begin
698 (display "#<foreign-object " file)
699 (display (class-name class) file)
700 (display #\space file)
701 (display-address o file)
702 (display #\> file))
703 (next-method))))
705 (define-method (write (class <class>) file)
706 (let ((meta (class-of class)))
707 (if (and (slot-bound? class 'name)
708 (slot-bound? meta 'name))
709 (begin
710 (display "#<" file)
711 (display (class-name meta) file)
712 (display #\space file)
713 (display (class-name class) file)
714 (display #\space file)
715 (display-address class file)
716 (display #\> file))
717 (next-method))))
719 (define-method (write (gf <generic>) file)
720 (let ((meta (class-of gf)))
721 (if (and (slot-bound? meta 'name)
722 (slot-bound? gf 'methods))
723 (begin
724 (display "#<" file)
725 (display (class-name meta) file)
726 (let ((name (generic-function-name gf)))
727 (if name
728 (begin
729 (display #\space file)
730 (display name file))))
731 (display " (" file)
732 (display (length (generic-function-methods gf)) file)
733 (display ")>" file))
734 (next-method))))
736 (define-method (write (o <method>) file)
737 (let ((meta (class-of o)))
738 (if (and (slot-bound? meta 'name)
739 (slot-bound? o 'specializers))
740 (begin
741 (display "#<" file)
742 (display (class-name meta) file)
743 (display #\space file)
744 (display (map* (lambda (spec)
745 (if (slot-bound? spec 'name)
746 (slot-ref spec 'name)
747 spec))
748 (method-specializers o))
749 file)
750 (display #\space file)
751 (display-address o file)
752 (display #\> file))
753 (next-method))))
755 ;; Display (do the same thing as write by default)
756 (define-method (display o file)
757 (write-object o file))
759 ;;;
760 ;;; slot access
761 ;;;
763 (define (class-slot-g-n-s class slot-name)
764 (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
765 (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
766 (slot-missing class slot-name)))))
767 (if (not (memq (slot-definition-allocation this-slot)
768 '(#:class #:each-subclass)))
769 (slot-missing class slot-name))
770 g-n-s))
772 (define (class-slot-ref class slot)
773 (let ((x ((car (class-slot-g-n-s class slot)) #f)))
774 (if (unbound? x)
775 (slot-unbound class slot)
776 x)))
778 (define (class-slot-set! class slot value)
779 ((cadr (class-slot-g-n-s class slot)) #f value))
781 (define-method (slot-unbound (c <class>) (o <object>) s)
782 (goops-error "Slot `~S' is unbound in object ~S" s o))
784 (define-method (slot-unbound (c <class>) s)
785 (goops-error "Slot `~S' is unbound in class ~S" s c))
787 (define-method (slot-unbound (o <object>))
788 (goops-error "Unbound slot in object ~S" o))
790 (define-method (slot-missing (c <class>) (o <object>) s)
791 (goops-error "No slot with name `~S' in object ~S" s o))
793 (define-method (slot-missing (c <class>) s)
794 (goops-error "No class slot with name `~S' in class ~S" s c))
797 (define-method (slot-missing (c <class>) (o <object>) s value)
798 (slot-missing c o s))
800 ;;; Methods for the possible error we can encounter when calling a gf
802 (define-method (no-next-method (gf <generic>) args)
803 (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
805 (define-method (no-applicable-method (gf <generic>) args)
806 (goops-error "No applicable method for ~S in call ~S"
807 gf (cons (generic-function-name gf) args)))
809 (define-method (no-method (gf <generic>) args)
810 (goops-error "No method defined for ~S" gf))
812 ;;;
813 ;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
814 ;;;
816 (define-method (shallow-clone (self <object>))
817 (let ((clone (%allocate-instance (class-of self) '()))
818 (slots (map slot-definition-name
819 (class-slots (class-of self)))))
820 (for-each (lambda (slot)
821 (if (slot-bound? self slot)
822 (slot-set! clone slot (slot-ref self slot))))
823 slots)
824 clone))
826 (define-method (deep-clone (self <object>))
827 (let ((clone (%allocate-instance (class-of self) '()))
828 (slots (map slot-definition-name
829 (class-slots (class-of self)))))
830 (for-each (lambda (slot)
831 (if (slot-bound? self slot)
832 (slot-set! clone slot
833 (let ((value (slot-ref self slot)))
834 (if (instance? value)
835 (deep-clone value)
836 value)))))
837 slots)
838 clone))
840 ;;;
841 ;;; {Class redefinition utilities}
842 ;;;
844 ;;; (class-redefinition OLD NEW)
845 ;;;
847 ;;; Has correct the following conditions:
849 ;;; Methods
850 ;;;
851 ;;; 1. New accessor specializers refer to new header
852 ;;;
853 ;;; Classes
854 ;;;
855 ;;; 1. New class cpl refers to the new class header
856 ;;; 2. Old class header exists on old super classes direct-subclass lists
857 ;;; 3. New class header exists on new super classes direct-subclass lists
859 (define-method (class-redefinition (old <class>) (new <class>))
860 ;; Work on direct methods:
861 ;; 1. Remove accessor methods from the old class
862 ;; 2. Patch the occurences of new in the specializers by old
863 ;; 3. Displace the methods from old to new
864 (remove-class-accessors! old) ;; -1-
865 (let ((methods (class-direct-methods new)))
866 (for-each (lambda (m)
867 (update-direct-method! m new old)) ;; -2-
868 methods)
869 (slot-set! new
870 'direct-methods
871 (append methods (class-direct-methods old))))
873 ;; Substitute old for new in new cpl
874 (set-car! (slot-ref new 'cpl) old)
876 ;; Remove the old class from the direct-subclasses list of its super classes
877 (for-each (lambda (c) (slot-set! c 'direct-subclasses
878 (delv! old (class-direct-subclasses c))))
879 (class-direct-supers old))
881 ;; Replace the new class with the old in the direct-subclasses of the supers
882 (for-each (lambda (c)
883 (slot-set! c 'direct-subclasses
884 (cons old (delv! new (class-direct-subclasses c)))))
885 (class-direct-supers new))
887 ;; Swap object headers
888 (%modify-class old new)
890 ;; Now old is NEW!
892 ;; Redefine all the subclasses of old to take into account modification
893 (for-each
894 (lambda (c)
895 (update-direct-subclass! c new old))
896 (class-direct-subclasses new))
898 ;; Invalidate class so that subsequent instances slot accesses invoke
899 ;; change-object-class
900 (slot-set! new 'redefined old)
901 (%invalidate-class new) ;must come after slot-set!
903 old)
905 ;;;
906 ;;; remove-class-accessors!
907 ;;;
909 (define-method (remove-class-accessors! (c <class>))
910 (for-each (lambda (m)
911 (if (is-a? m <accessor-method>)
912 (remove-method-in-classes! m)))
913 (class-direct-methods c)))
915 ;;;
916 ;;; update-direct-method!
917 ;;;
919 (define-method (update-direct-method! (m <method>)
920 (old <class>)
921 (new <class>))
922 (let loop ((l (method-specializers m)))
923 ;; Note: the <top> in dotted list is never used.
924 ;; So we can work as if we had only proper lists.
925 (if (pair? l)
926 (begin
927 (if (eqv? (car l) old)
928 (set-car! l new))
929 (loop (cdr l))))))
931 ;;;
932 ;;; update-direct-subclass!
933 ;;;
935 (define-method (update-direct-subclass! (c <class>)
936 (old <class>)
937 (new <class>))
938 (class-redefinition c
939 (make-class (class-direct-supers c)
940 (class-direct-slots c)
941 #:name (class-name c)
942 #:environment (slot-ref c 'environment)
943 #:metaclass (class-of c))))
945 ;;;
946 ;;; {Utilities for INITIALIZE methods}
947 ;;;
949 ;;; compute-slot-accessors
950 ;;;
951 (define (compute-slot-accessors class slots env)
952 (for-each
953 (lambda (s g-n-s)
954 (let ((name (slot-definition-name s))
955 (getter-function (slot-definition-getter s))
956 (setter-function (slot-definition-setter s))
957 (accessor (slot-definition-accessor s)))
958 (if getter-function
959 (add-method! getter-function
960 (compute-getter-method class g-n-s)))
961 (if setter-function
962 (add-method! setter-function
963 (compute-setter-method class g-n-s)))
964 (if accessor
965 (begin
966 (add-method! accessor
967 (compute-getter-method class g-n-s))
968 (add-method! (setter accessor)
969 (compute-setter-method class g-n-s))))))
970 slots (slot-ref class 'getters-n-setters)))
972 (define-method (compute-getter-method (class <class>) slotdef)
973 (let ((init-thunk (cadr slotdef))
974 (g-n-s (cddr slotdef)))
975 (make <accessor-method>
976 #:specializers (list class)
977 #:procedure (cond ((pair? g-n-s)
978 (if init-thunk
979 (car g-n-s)
980 (make-generic-bound-check-getter (car g-n-s))
981 ))
982 (init-thunk
983 (standard-get g-n-s))
984 (else
985 (bound-check-get g-n-s)))
986 #:slot-definition slotdef)))
988 (define-method (compute-setter-method (class <class>) slotdef)
989 (let ((g-n-s (cddr slotdef)))
990 (make <accessor-method>
991 #:specializers (list class <top>)
992 #:procedure (if (pair? g-n-s)
993 (cadr g-n-s)
994 (standard-set g-n-s))
995 #:slot-definition slotdef)))
997 (define (make-generic-bound-check-getter proc)
998 (let ((source (and (closure? proc) (procedure-source proc))))
999 (if (and source (null? (cdddr source)))
1000 (let ((obj (caadr source)))
1001 ;; smart closure compilation
1002 (local-eval
1003 `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
1004 (procedure-environment proc)))
1005 (lambda (o) (assert-bound (proc o) o)))))
1007 (define n-standard-accessor-methods 10)
1009 (define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
1010 (define standard-get-methods (make-vector n-standard-accessor-methods #f))
1011 (define standard-set-methods (make-vector n-standard-accessor-methods #f))
1013 (define (standard-accessor-method make methods)
1014 (lambda (index)
1015 (cond ((>= index n-standard-accessor-methods) (make index))
1016 ((vector-ref methods index))
1017 (else (let ((m (make index)))
1018 (vector-set! methods index m)
1019 m)))))
1021 (define (make-bound-check-get index)
1022 (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
1024 (define (make-get index)
1025 (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
1027 (define (make-set index)
1028 (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
1030 (define bound-check-get
1031 (standard-accessor-method make-bound-check-get bound-check-get-methods))
1032 (define standard-get (standard-accessor-method make-get standard-get-methods))
1033 (define standard-set (standard-accessor-method make-set standard-set-methods))
1035 ;;; compute-getters-n-setters
1036 ;;;
1037 (define (compute-getters-n-setters class slots env)
1039 (define (compute-slot-init-function s)
1040 (or (slot-definition-init-thunk s)
1041 (let ((init (slot-definition-init-value s)))
1042 (and (not (unbound? init))
1043 (lambda () init)))))
1045 (define (verify-accessors slot l)
1046 (if (pair? l)
1047 (let ((get (car l))
1048 (set (cadr l)))
1049 (if (not (and (closure? get)
1050 (= (car (procedure-property get 'arity)) 1)))
1051 (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
1052 slot class get))
1053 (if (not (and (closure? set)
1054 (= (car (procedure-property set 'arity)) 2)))
1055 (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
1056 slot class set)))))
1058 (map (lambda (s)
1059 (let* ((g-n-s (compute-get-n-set class s))
1060 (name (slot-definition-name s)))
1061 ; For each slot we have '(name init-function getter setter)
1062 ; If slot, we have the simplest form '(name init-function . index)
1063 (verify-accessors name g-n-s)
1064 (cons name
1065 (cons (compute-slot-init-function s)
1066 g-n-s))))
1067 slots))
1069 ;;; compute-cpl
1070 ;;;
1071 ;;; Correct behaviour:
1072 ;;;
1073 ;;; (define-class food ())
1074 ;;; (define-class fruit (food))
1075 ;;; (define-class spice (food))
1076 ;;; (define-class apple (fruit))
1077 ;;; (define-class cinnamon (spice))
1078 ;;; (define-class pie (apple cinnamon))
1079 ;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
1080 ;;;
1081 ;;; (define-class d ())
1082 ;;; (define-class e ())
1083 ;;; (define-class f ())
1084 ;;; (define-class b (d e))
1085 ;;; (define-class c (e f))
1086 ;;; (define-class a (b c))
1087 ;;; => cpl (a) = a b d c e f object top
1088 ;;;
1090 (define-method (compute-cpl (class <class>))
1091 (compute-std-cpl class class-direct-supers))
1093 ;; Support
1095 (define (only-non-null lst)
1096 (filter (lambda (l) (not (null? l))) lst))
1098 (define (compute-std-cpl c get-direct-supers)
1099 (let ((c-direct-supers (get-direct-supers c)))
1100 (merge-lists (list c)
1101 (only-non-null (append (map class-precedence-list
1102 c-direct-supers)
1103 (list c-direct-supers))))))
1105 (define (merge-lists reversed-partial-result inputs)
1106 (cond
1107 ((every null? inputs)
1108 (reverse! reversed-partial-result))
1109 (else
1110 (let* ((candidate (lambda (c)
1111 (and (not (any (lambda (l)
1112 (memq c (cdr l)))
1113 inputs))
1114 c)))
1115 (candidate-car (lambda (l)
1116 (and (not (null? l))
1117 (candidate (car l)))))
1118 (next (any candidate-car inputs)))
1119 (if (not next)
1120 (goops-error "merge-lists: Inconsistent precedence graph"))
1121 (let ((remove-next (lambda (l)
1122 (if (eq? (car l) next)
1123 (cdr l)
1124 l))))
1125 (merge-lists (cons next reversed-partial-result)
1126 (only-non-null (map remove-next inputs))))))))
1128 ;; Modified from TinyClos:
1129 ;;
1130 ;; A simple topological sort.
1131 ;;
1132 ;; It's in this file so that both TinyClos and Objects can use it.
1133 ;;
1134 ;; This is a fairly modified version of code I originally got from Anurag
1135 ;; Mendhekar <anurag@moose.cs.indiana.edu>.
1136 ;;
1138 (define (compute-clos-cpl c get-direct-supers)
1139 (top-sort ((build-transitive-closure get-direct-supers) c)
1140 ((build-constraints get-direct-supers) c)
1141 (std-tie-breaker get-direct-supers)))
1144 (define (top-sort elements constraints tie-breaker)
1145 (let loop ((elements elements)
1146 (constraints constraints)
1147 (result '()))
1148 (if (null? elements)
1149 result
1150 (let ((can-go-in-now
1151 (filter
1152 (lambda (x)
1153 (every (lambda (constraint)
1154 (or (not (eq? (cadr constraint) x))
1155 (memq (car constraint) result)))
1156 constraints))
1157 elements)))
1158 (if (null? can-go-in-now)
1159 (goops-error "top-sort: Invalid constraints")
1160 (let ((choice (if (null? (cdr can-go-in-now))
1161 (car can-go-in-now)
1162 (tie-breaker result
1163 can-go-in-now))))
1164 (loop
1165 (filter (lambda (x) (not (eq? x choice)))
1166 elements)
1167 constraints
1168 (append result (list choice)))))))))
1170 (define (std-tie-breaker get-supers)
1171 (lambda (partial-cpl min-elts)
1172 (let loop ((pcpl (reverse partial-cpl)))
1173 (let ((current-elt (car pcpl)))
1174 (let ((ds-of-ce (get-supers current-elt)))
1175 (let ((common (filter (lambda (x)
1176 (memq x ds-of-ce))
1177 min-elts)))
1178 (if (null? common)
1179 (if (null? (cdr pcpl))
1180 (goops-error "std-tie-breaker: Nothing valid")
1181 (loop (cdr pcpl)))
1182 (car common))))))))
1185 (define (build-transitive-closure get-follow-ons)
1186 (lambda (x)
1187 (let track ((result '())
1188 (pending (list x)))
1189 (if (null? pending)
1190 result
1191 (let ((next (car pending)))
1192 (if (memq next result)
1193 (track result (cdr pending))
1194 (track (cons next result)
1195 (append (get-follow-ons next)
1196 (cdr pending)))))))))
1198 (define (build-constraints get-follow-ons)
1199 (lambda (x)
1200 (let loop ((elements ((build-transitive-closure get-follow-ons) x))
1201 (this-one '())
1202 (result '()))
1203 (if (or (null? this-one) (null? (cdr this-one)))
1204 (if (null? elements)
1205 result
1206 (loop (cdr elements)
1207 (cons (car elements)
1208 (get-follow-ons (car elements)))
1209 result))
1210 (loop elements
1211 (cdr this-one)
1212 (cons (list (car this-one) (cadr this-one))
1213 result))))))
1215 ;;; compute-get-n-set
1216 ;;;
1217 (define-method (compute-get-n-set (class <class>) s)
1218 (case (slot-definition-allocation s)
1219 ((#:instance) ;; Instance slot
1220 ;; get-n-set is just its offset
1221 (let ((already-allocated (slot-ref class 'nfields)))
1222 (slot-set! class 'nfields (+ already-allocated 1))
1223 already-allocated))
1225 ((#:class) ;; Class slot
1226 ;; Class-slots accessors are implemented as 2 closures around
1227 ;; a Scheme variable. As instance slots, class slots must be
1228 ;; unbound at init time.
1229 (let ((name (slot-definition-name s)))
1230 (if (memq name (map slot-definition-name (class-direct-slots class)))
1231 ;; This slot is direct; create a new shared variable
1232 (make-closure-variable class)
1233 ;; Slot is inherited. Find its definition in superclass
1234 (let loop ((l (cdr (class-precedence-list class))))
1235 (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
1236 (if r
1237 (cddr r)
1238 (loop (cdr l))))))))
1240 ((#:each-subclass) ;; slot shared by instances of direct subclass.
1241 ;; (Thomas Buerger, April 1998)
1242 (make-closure-variable class))
1244 ((#:virtual) ;; No allocation
1245 ;; slot-ref and slot-set! function must be given by the user
1246 (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
1247 (set (get-keyword #:slot-set! (slot-definition-options s) #f))
1248 (env (class-environment class)))
1249 (if (not (and get set))
1250 (goops-error "You must supply a :slot-ref and a :slot-set! in ~S"
1251 s))
1252 (list get set)))
1253 (else (next-method))))
1255 (define (make-closure-variable class)
1256 (let ((shared-variable (make-unbound)))
1257 (list (lambda (o) shared-variable)
1258 (lambda (o v) (set! shared-variable v)))))
1260 (define-method (compute-get-n-set (o <object>) s)
1261 (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
1263 (define-method (compute-slots (class <class>))
1264 (%compute-slots class))
1266 ;;;
1267 ;;; {Initialize}
1268 ;;;
1270 (define-method (initialize (object <object>) initargs)
1271 (%initialize-object object initargs))
1273 (define-method (initialize (class <class>) initargs)
1274 (next-method)
1275 (let ((dslots (get-keyword #:slots initargs '()))
1276 (supers (get-keyword #:dsupers initargs '()))
1277 (env (get-keyword #:environment initargs (top-level-env))))
1279 (slot-set! class 'name (get-keyword #:name initargs '???))
1280 (slot-set! class 'direct-supers supers)
1281 (slot-set! class 'direct-slots dslots)
1282 (slot-set! class 'direct-subclasses '())
1283 (slot-set! class 'direct-methods '())
1284 (slot-set! class 'cpl (compute-cpl class))
1285 (slot-set! class 'redefined #f)
1286 (slot-set! class 'environment env)
1287 (let ((slots (compute-slots class)))
1288 (slot-set! class 'slots slots)
1289 (slot-set! class 'nfields 0)
1290 (slot-set! class 'getters-n-setters (compute-getters-n-setters class
1291 slots
1292 env))
1293 ;; Build getters - setters - accessors
1294 (compute-slot-accessors class slots env))
1296 ;; Update the "direct-subclasses" of each inherited classes
1297 (for-each (lambda (x)
1298 (slot-set! x
1299 'direct-subclasses
1300 (cons class (slot-ref x 'direct-subclasses))))
1301 supers)
1303 ;; Support for the underlying structs:
1305 ;; Inherit class flags (invisible on scheme level) from supers
1306 (%inherit-magic! class supers)
1308 ;; Set the layout slot
1309 (%prep-layout! class)))
1311 (define (initialize-object-procedure object initargs)
1312 (let ((proc (get-keyword #:procedure initargs #f)))
1313 (cond ((not proc))
1314 ((pair? proc)
1315 (apply set-object-procedure! object proc))
1316 ((valid-object-procedure? proc)
1317 (set-object-procedure! object proc))
1318 (else
1319 (set-object-procedure! object
1320 (lambda args (apply proc args)))))))
1322 (define-method (initialize (class <operator-class>) initargs)
1323 (next-method)
1324 (initialize-object-procedure class initargs))
1326 (define-method (initialize (owsc <operator-with-setter-class>) initargs)
1327 (next-method)
1328 (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
1330 (define-method (initialize (entity <entity>) initargs)
1331 (next-method)
1332 (initialize-object-procedure entity initargs))
1334 (define-method (initialize (ews <entity-with-setter>) initargs)
1335 (next-method)
1336 (%set-object-setter! ews (get-keyword #:setter initargs #f)))
1338 (define-method (initialize (generic <generic>) initargs)
1339 (let ((previous-definition (get-keyword #:default initargs #f))
1340 (name (get-keyword #:name initargs #f)))
1341 (next-method)
1342 (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
1343 (list (make <method>
1344 #:specializers <top>
1345 #:procedure
1346 (lambda l
1347 (apply previous-definition
1348 l))))
1349 '()))
1350 (if name
1351 (set-procedure-property! generic 'name name))
1352 ))
1354 (define dummy-procedure (lambda args *unspecified*))
1356 (define-method (initialize (method <method>) initargs)
1357 (next-method)
1358 (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
1359 (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
1360 (slot-set! method 'procedure
1361 (get-keyword #:procedure initargs dummy-procedure))
1362 (slot-set! method 'code-table '()))
1364 (define-method (initialize (obj <foreign-object>) initargs))
1366 ;;;
1367 ;;; {Change-class}
1368 ;;;
1370 (define (change-object-class old-instance old-class new-class)
1371 (let ((new-instance (allocate-instance new-class '())))
1372 ;; Initalize the slot of the new instance
1373 (for-each (lambda (slot)
1374 (if (and (slot-exists-using-class? old-class old-instance slot)
1375 (eq? (slot-definition-allocation
1376 (class-slot-definition old-class slot))
1377 #:instance)
1378 (slot-bound-using-class? old-class old-instance slot))
1379 ;; Slot was present and allocated in old instance; copy it
1380 (slot-set-using-class!
1381 new-class
1382 new-instance
1383 slot
1384 (slot-ref-using-class old-class old-instance slot))
1385 ;; slot was absent; initialize it with its default value
1386 (let ((init (slot-init-function new-class slot)))
1387 (if init
1388 (slot-set-using-class!
1389 new-class
1390 new-instance
1391 slot
1392 (apply init '()))))))
1393 (map slot-definition-name (class-slots new-class)))
1394 ;; Exchange old and new instance in place to keep pointers valid
1395 (%modify-instance old-instance new-instance)
1396 ;; Allow class specific updates of instances (which now are swapped)
1397 (update-instance-for-different-class new-instance old-instance)
1398 old-instance))
1401 (define-method (update-instance-for-different-class (old-instance <object>)
1402 (new-instance
1403 <object>))
1404 ;;not really important what we do, we just need a default method
1405 new-instance)
1407 (define-method (change-class (old-instance <object>) (new-class <class>))
1408 (change-object-class old-instance (class-of old-instance) new-class))
1410 ;;;
1411 ;;; {make}
1412 ;;;
1413 ;;; A new definition which overwrites the previous one which was built-in
1414 ;;;
1416 (define-method (allocate-instance (class <class>) initargs)
1417 (%allocate-instance class initargs))
1419 (define-method (make-instance (class <class>) . initargs)
1420 (let ((instance (allocate-instance class initargs)))
1421 (initialize instance initargs)
1422 instance))
1424 (define make make-instance)
1426 ;;;
1427 ;;; {apply-generic}
1428 ;;;
1429 ;;; Protocol for calling standard generic functions. This protocol is
1430 ;;; not used for real <generic> functions (in this case we use a
1431 ;;; completely C hard-coded protocol). Apply-generic is used by
1432 ;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
1433 ;;; The code below is similar to the first MOP described in AMOP. In
1434 ;;; particular, it doesn't used the currified approach to gf
1435 ;;; call. There are 2 reasons for that:
1436 ;;; - the protocol below is exposed to mimic completely the one written in C
1437 ;;; - the currified protocol would be imho inefficient in C.
1438 ;;;
1440 (define-method (apply-generic (gf <generic>) args)
1441 (if (null? (slot-ref gf 'methods))
1442 (no-method gf args))
1443 (let ((methods (compute-applicable-methods gf args)))
1444 (if methods
1445 (apply-methods gf (sort-applicable-methods gf methods args) args)
1446 (no-applicable-method gf args))))
1448 ;; compute-applicable-methods is bound to %compute-applicable-methods.
1449 ;; *fixme* use let
1450 (define %%compute-applicable-methods
1451 (make <generic> #:name 'compute-applicable-methods))
1453 (define-method (%%compute-applicable-methods (gf <generic>) args)
1454 (%compute-applicable-methods gf args))
1456 (set! compute-applicable-methods %%compute-applicable-methods)
1458 (define-method (sort-applicable-methods (gf <generic>) methods args)
1459 (let ((targs (map class-of args)))
1460 (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
1462 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
1463 (%method-more-specific? m1 m2 targs))
1465 (define-method (apply-method (gf <generic>) methods build-next args)
1466 (apply (method-procedure (car methods))
1467 (build-next (cdr methods) args)
1468 args))
1470 (define-method (apply-methods (gf <generic>) (l <list>) args)
1471 (letrec ((next (lambda (procs args)
1472 (lambda new-args
1473 (let ((a (if (null? new-args) args new-args)))
1474 (if (null? procs)
1475 (no-next-method gf a)
1476 (apply-method gf procs next a)))))))
1477 (apply-method gf l next args)))
1479 ;; We don't want the following procedure to turn up in backtraces:
1480 (for-each (lambda (proc)
1481 (set-procedure-property! proc 'system-procedure #t))
1482 (list slot-unbound
1483 slot-missing
1484 no-next-method
1485 no-applicable-method
1486 no-method
1487 ))
1489 ;;;
1490 ;;; {<composite-metaclass> and <active-metaclass>}
1491 ;;;
1493 ;(autoload "active-slot" <active-metaclass>)
1494 ;(autoload "composite-slot" <composite-metaclass>)
1495 ;(export <composite-metaclass> <active-metaclass>)
1497 ;;;
1498 ;;; {Tools}
1499 ;;;
1501 ;; list2set
1502 ;;
1503 ;; duplicate the standard list->set function but using eq instead of
1504 ;; eqv which really sucks a lot, uselessly here
1505 ;;
1506 (define (list2set l)
1507 (let loop ((l l)
1508 (res '()))
1509 (cond
1510 ((null? l) res)
1511 ((memq (car l) res) (loop (cdr l) res))
1512 (else (loop (cdr l) (cons (car l) res))))))
1514 (define (class-subclasses c)
1515 (letrec ((allsubs (lambda (c)
1516 (cons c (mapappend allsubs
1517 (class-direct-subclasses c))))))
1518 (list2set (cdr (allsubs c)))))
1520 (define (class-methods c)
1521 (list2set (mapappend class-direct-methods
1522 (cons c (class-subclasses c)))))
1524 ;;;
1525 ;;; {Final initialization}
1526 ;;;
1528 ;; Tell C code that the main bulk of Goops has been loaded
1529 (%goops-loaded)