1
;; This file overrides two functions inside TinyCLOS to provide support
2
;; for multi-argument generics. There are many ways of linking this file
3
;; into your code... all that needs to happen is this file must be
4
;; executed after loading TinyCLOS but before any SWIG modules are loaded
6
;; something like the following
8
;; (load "multi-generic")
9
;; (declare (uses swigmod))
11
;; An alternative to loading this scheme code directly is to add a
12
;; (declare (unit multi-generic)) to the top of this file, and then
13
;; compile this into the final executable or something. Or compile
14
;; this into an extension.
16
;; Lastly, to override TinyCLOS method creation, two functions are
17
;; overridden: see the end of this file for which two are overridden.
18
;; You might want to remove those two lines and then exert more control over
19
;; which functions are used when.
21
;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to
22
;; Author: John Lenz <lenz@cs.wisc.edu>, most code copied from TinyCLOS
24
(define <multi-generic> (make <entity-class>
26
'direct-supers (list <generic>)
31
(memq c (class-cpl (class-of arg))))]
35
(memq c2 (memq c1 (class-cpl (class-of arg)))))]
41
(let ([h (##sys#slot l 0)]
42
[r (##sys#slot l 1)] )
44
(cons h (filter-in f r))
45
(filter-in f r) ) ) ) )])
47
(add-method compute-apply-generic
48
(make-method (list <multi-generic>)
49
(lambda (call-next-method generic)
51
(let ([cam (let ([x (compute-apply-methods generic)]
52
[y ((compute-methods generic) args)] )
53
(lambda (args) (x y args)) ) ] )
58
(add-method compute-methods
59
(make-method (list <multi-generic>)
60
(lambda (call-next-method generic)
63
(filter-in (lambda (method)
64
(let check-applicable ([list1 (method-specializers method)]
66
(cond ((null? list1) #t)
69
(and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
70
(check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
71
(generic-methods generic) ) ] )
72
(if (or (null? applicable) (null? (##sys#slot applicable 1)))
74
(let ([cmms (compute-method-more-specific? generic)])
75
(sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )
77
(add-method compute-method-more-specific?
78
(make-method (list <multi-generic>)
79
(lambda (call-next-method generic)
81
(let loop ((specls1 (method-specializers m1))
82
(specls2 (method-specializers m2))
86
(let ((c1 (##sys#slot specls1 0))
87
(c2 (##sys#slot specls2 0))
88
(arg (##sys#slot args 0)))
90
(loop (##sys#slot specls1 1)
91
(##sys#slot specls2 1)
93
(more-specific? c1 c2 arg))) ]
95
(cond ((and (null? specls1) (null? specls2))
96
(##sys#error "two methods are equally specific" generic))
97
;((or (null? specls1) (null? specls2))
98
; (##sys#error "two methods have different number of specializers" generic))
102
(##sys#error "fewer arguments than specializers" generic))
104
(let ((c1 (##sys#slot specls1 0))
105
(c2 (##sys#slot specls2 0))
106
(arg (##sys#slot args 0)))
108
(loop (##sys#slot specls1 1)
109
(##sys#slot specls2 1)
111
(more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) )
115
(define multi-add-method
116
(lambda (generic method)
120
(let filter-in-method ([methods (slot-ref generic 'methods)])
123
(let ([l1 (length (method-specializers method))]
124
[l2 (length (method-specializers (##sys#slot methods 0)))])
126
(cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
128
(cons method methods))
130
(let check-method ([ms1 (method-specializers method)]
131
[ms2 (method-specializers (##sys#slot methods 0))])
132
(cond ((and (null? ms1) (null? ms2))
133
(cons method (##sys#slot methods 1))) ;; skip the method already in the generic
134
((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
135
(check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
137
(cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))
139
(##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) ))
141
(define (multi-add-global-method val sym specializers proc)
142
(let ((generic (if (procedure? val) val (make <multi-generic> 'name (##sys#symbol->string sym)))))
143
(multi-add-method generic (make-method specializers proc))
146
;; Might want to remove these, or perhaps do something like
147
;; (define old-add-method ##tinyclos#add-method)
148
;; and then you can switch between creating multi-generics and TinyCLOS generics.
149
(set! ##tinyclos#add-method multi-add-method)
150
(set! ##tinyclos#add-global-method multi-add-global-method)
added
removed
Lib/chicken/multi-generic.scm
