Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | |
5 | ;; | |
6 | ;; something like the following | |
7 | ;; (require 'tinyclos) | |
8 | ;; (load "multi-generic") | |
9 | ;; (declare (uses swigmod)) | |
10 | ;; | |
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. | |
15 | ||
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. | |
20 | ||
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 | |
23 | ||
24 | (define <multi-generic> (make <entity-class> | |
25 | 'name "multi-generic" | |
26 | 'direct-supers (list <generic>) | |
27 | 'direct-slots '())) | |
28 | ||
29 | (letrec ([applicable? | |
30 | (lambda (c arg) | |
31 | (memq c (class-cpl (class-of arg))))] | |
32 | ||
33 | [more-specific? | |
34 | (lambda (c1 c2 arg) | |
35 | (memq c2 (memq c1 (class-cpl (class-of arg)))))] | |
36 | ||
37 | [filter-in | |
38 | (lambda (f l) | |
39 | (if (null? l) | |
40 | '() | |
41 | (let ([h (##sys#slot l 0)] | |
42 | [r (##sys#slot l 1)] ) | |
43 | (if (f h) | |
44 | (cons h (filter-in f r)) | |
45 | (filter-in f r) ) ) ) )]) | |
46 | ||
47 | (add-method compute-apply-generic | |
48 | (make-method (list <multi-generic>) | |
49 | (lambda (call-next-method generic) | |
50 | (lambda args | |
51 | (let ([cam (let ([x (compute-apply-methods generic)] | |
52 | [y ((compute-methods generic) args)] ) | |
53 | (lambda (args) (x y args)) ) ] ) | |
54 | (cam args) ) ) ) ) ) | |
55 | ||
56 | ||
57 | ||
58 | (add-method compute-methods | |
59 | (make-method (list <multi-generic>) | |
60 | (lambda (call-next-method generic) | |
61 | (lambda (args) | |
62 | (let ([applicable | |
63 | (filter-in (lambda (method) | |
64 | (let check-applicable ([list1 (method-specializers method)] | |
65 | [list2 args]) | |
66 | (cond ((null? list1) #t) | |
67 | ((null? list2) #f) | |
68 | (else | |
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))) | |
73 | applicable | |
74 | (let ([cmms (compute-method-more-specific? generic)]) | |
75 | (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) ) | |
76 | ||
77 | (add-method compute-method-more-specific? | |
78 | (make-method (list <multi-generic>) | |
79 | (lambda (call-next-method generic) | |
80 | (lambda (m1 m2 args) | |
81 | (let loop ((specls1 (method-specializers m1)) | |
82 | (specls2 (method-specializers m2)) | |
83 | (args args)) | |
84 | (cond-expand | |
85 | [unsafe | |
86 | (let ((c1 (##sys#slot specls1 0)) | |
87 | (c2 (##sys#slot specls2 0)) | |
88 | (arg (##sys#slot args 0))) | |
89 | (if (eq? c1 c2) | |
90 | (loop (##sys#slot specls1 1) | |
91 | (##sys#slot specls2 1) | |
92 | (##sys#slot args 1)) | |
93 | (more-specific? c1 c2 arg))) ] | |
94 | [else | |
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)) | |
99 | ((null? specls1) #f) | |
100 | ((null? specls2) #t) | |
101 | ((null? args) | |
102 | (##sys#error "fewer arguments than specializers" generic)) | |
103 | (else | |
104 | (let ((c1 (##sys#slot specls1 0)) | |
105 | (c2 (##sys#slot specls2 0)) | |
106 | (arg (##sys#slot args 0))) | |
107 | (if (eq? c1 c2) | |
108 | (loop (##sys#slot specls1 1) | |
109 | (##sys#slot specls2 1) | |
110 | (##sys#slot args 1)) | |
111 | (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) ) | |
112 | ||
113 | ) ;; end of letrec | |
114 | ||
115 | (define multi-add-method | |
116 | (lambda (generic method) | |
117 | (slot-set! | |
118 | generic | |
119 | 'methods | |
120 | (let filter-in-method ([methods (slot-ref generic 'methods)]) | |
121 | (if (null? methods) | |
122 | (list method) | |
123 | (let ([l1 (length (method-specializers method))] | |
124 | [l2 (length (method-specializers (##sys#slot methods 0)))]) | |
125 | (cond ((> l1 l2) | |
126 | (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))) | |
127 | ((< l1 l2) | |
128 | (cons method methods)) | |
129 | (else | |
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))) | |
136 | (else | |
137 | (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))))))))))) | |
138 | ||
139 | (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) )) | |
140 | ||
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)) | |
144 | generic)) | |
145 | ||
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) |