| 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) |