1 ;; This file is no longer necessary with Chicken versions above 1.92
3 ;; This file overrides two functions inside TinyCLOS to provide support
4 ;; for multi-argument generics. There are many ways of linking this file
5 ;; into your code... all that needs to happen is this file must be
6 ;; executed after loading TinyCLOS but before any SWIG modules are loaded
8 ;; something like the following
10 ;; (load "multi-generic")
11 ;; (declare (uses swigmod))
13 ;; An alternative to loading this scheme code directly is to add a
14 ;; (declare (unit multi-generic)) to the top of this file, and then
15 ;; compile this into the final executable or something. Or compile
16 ;; this into an extension.
18 ;; Lastly, to override TinyCLOS method creation, two functions are
19 ;; overridden: see the end of this file for which two are overridden.
20 ;; You might want to remove those two lines and then exert more control over
21 ;; which functions are used when.
23 ;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to
24 ;; Author: John Lenz <lenz@cs.wisc.edu>, most code copied from TinyCLOS
26 (define <multi-generic> (make <entity-class>
28 'direct-supers (list <generic>)
33 (memq c (class-cpl (class-of arg))))]
37 (memq c2 (memq c1 (class-cpl (class-of arg)))))]
43 (let ([h (##sys#slot l 0)]
44 [r (##sys#slot l 1)] )
46 (cons h (filter-in f r))
47 (filter-in f r) ) ) ) )])
49 (add-method compute-apply-generic
50 (make-method (list <multi-generic>)
51 (lambda (call-next-method generic)
53 (let ([cam (let ([x (compute-apply-methods generic)]
54 [y ((compute-methods generic) args)] )
55 (lambda (args) (x y args)) ) ] )
60 (add-method compute-methods
61 (make-method (list <multi-generic>)
62 (lambda (call-next-method generic)
65 (filter-in (lambda (method)
66 (let check-applicable ([list1 (method-specializers method)]
68 (cond ((null? list1) #t)
71 (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
72 (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
73 (generic-methods generic) ) ] )
74 (if (or (null? applicable) (null? (##sys#slot applicable 1)))
76 (let ([cmms (compute-method-more-specific? generic)])
77 (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )
79 (add-method compute-method-more-specific?
80 (make-method (list <multi-generic>)
81 (lambda (call-next-method generic)
83 (let loop ((specls1 (method-specializers m1))
84 (specls2 (method-specializers m2))
88 (let ((c1 (##sys#slot specls1 0))
89 (c2 (##sys#slot specls2 0))
90 (arg (##sys#slot args 0)))
92 (loop (##sys#slot specls1 1)
93 (##sys#slot specls2 1)
95 (more-specific? c1 c2 arg))) ]
97 (cond ((and (null? specls1) (null? specls2))
98 (##sys#error "two methods are equally specific" generic))
99 ;((or (null? specls1) (null? specls2))
100 ; (##sys#error "two methods have different number of specializers" generic))
104 (##sys#error "fewer arguments than specializers" generic))
106 (let ((c1 (##sys#slot specls1 0))
107 (c2 (##sys#slot specls2 0))
108 (arg (##sys#slot args 0)))
110 (loop (##sys#slot specls1 1)
111 (##sys#slot specls2 1)
113 (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) )
117 (define multi-add-method
118 (lambda (generic method)
122 (let filter-in-method ([methods (slot-ref generic 'methods)])
125 (let ([l1 (length (method-specializers method))]
126 [l2 (length (method-specializers (##sys#slot methods 0)))])
128 (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
130 (cons method methods))
132 (let check-method ([ms1 (method-specializers method)]
133 [ms2 (method-specializers (##sys#slot methods 0))])
134 (cond ((and (null? ms1) (null? ms2))
135 (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
136 ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
137 (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
139 (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))
141 (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) ))
143 (define (multi-add-global-method val sym specializers proc)
144 (let ((generic (if (procedure? val) val (make <multi-generic> 'name (##sys#symbol->string sym)))))
145 (multi-add-method generic (make-method specializers proc))
148 ;; Might want to remove these, or perhaps do something like
149 ;; (define old-add-method ##tinyclos#add-method)
150 ;; and then you can switch between creating multi-generics and TinyCLOS generics.
151 (set! ##tinyclos#add-method multi-add-method)
152 (set! ##tinyclos#add-global-method multi-add-global-method)