1 ;; This file is no longer necessary with Chicken versions above 1.92 2 ;; 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 7 ;; 8 ;; something like the following 9 ;; (require 'tinyclos) 10 ;; (load "multi-generic") 11 ;; (declare (uses swigmod)) 12 ;; 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. 17 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. 22 23 ;; Comments, bugs, suggestions: send either to chicken-users (at) nongnu.org or to 24 ;; Most code copied from TinyCLOS 25 26 (define(make 27 'name "multi-generic" 28 'direct-supers (list ) 29 'direct-slots '())) 30 31 (letrec ([applicable? 32 (lambda (c arg) 33 (memq c (class-cpl (class-of arg))))] 34 35 [more-specific? 36 (lambda (c1 c2 arg) 37 (memq c2 (memq c1 (class-cpl (class-of arg)))))] 38 39 [filter-in 40 (lambda (f l) 41 (if (null? l) 42 '() 43 (let ([h (##sys#slot l 0)] 44 [r (##sys#slot l 1)] ) 45 (if (f h) 46 (cons h (filter-in f r)) 47 (filter-in f r) ) ) ) )]) 48 49 (add-method compute-apply-generic 50 (make-method (list ) 51 (lambda (call-next-method generic) 52 (lambda args 53 (let ([cam (let ([x (compute-apply-methods generic)] 54 [y ((compute-methods generic) args)] ) 55 (lambda (args) (x y args)) ) ] ) 56 (cam args) ) ) ) ) ) 57 58 59 60 (add-method compute-methods 61 (make-method (list ) 62 (lambda (call-next-method generic) 63 (lambda (args) 64 (let ([applicable 65 (filter-in (lambda (method) 66 (let check-applicable ([list1 (method-specializers method)] 67 [list2 args]) 68 (cond ((null? list1) #t) 69 ((null? list2) #f) 70 (else 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))) 75 applicable 76 (let ([cmms (compute-method-more-specific? generic)]) 77 (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) ) 78 79 (add-method compute-method-more-specific? 80 (make-method (list ) 81 (lambda (call-next-method generic) 82 (lambda (m1 m2 args) 83 (let loop ((specls1 (method-specializers m1)) 84 (specls2 (method-specializers m2)) 85 (args args)) 86 (cond-expand 87 [unsafe 88 (let ((c1 (##sys#slot specls1 0)) 89 (c2 (##sys#slot specls2 0)) 90 (arg (##sys#slot args 0))) 91 (if (eq? c1 c2) 92 (loop (##sys#slot specls1 1) 93 (##sys#slot specls2 1) 94 (##sys#slot args 1)) 95 (more-specific? c1 c2 arg))) ] 96 [else 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)) 101 ((null? specls1) #f) 102 ((null? specls2) #t) 103 ((null? args) 104 (##sys#error "fewer arguments than specializers" generic)) 105 (else 106 (let ((c1 (##sys#slot specls1 0)) 107 (c2 (##sys#slot specls2 0)) 108 (arg (##sys#slot args 0))) 109 (if (eq? c1 c2) 110 (loop (##sys#slot specls1 1) 111 (##sys#slot specls2 1) 112 (##sys#slot args 1)) 113 (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) ) 114 115 ) ;; end of letrec 116 117 (define multi-add-method 118 (lambda (generic method) 119 (slot-set! 120 generic 121 'methods 122 (let filter-in-method ([methods (slot-ref generic 'methods)]) 123 (if (null? methods) 124 (list method) 125 (let ([l1 (length (method-specializers method))] 126 [l2 (length (method-specializers (##sys#slot methods 0)))]) 127 (cond ((> l1 l2) 128 (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))) 129 ((< l1 l2) 130 (cons method methods)) 131 (else 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))) 138 (else 139 (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1)))))))))))) 140 141 (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) )) 142 143 (define (multi-add-global-method val sym specializers proc) 144 (let ((generic (if (procedure? val) val (make 'name (##sys#symbol->string sym))))) 145 (multi-add-method generic (make-method specializers proc)) 146 generic)) 147 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) 153
