PageRenderTime 23ms CodeModel.GetById 9ms app.highlight 11ms RepoModel.GetById 1ms app.codeStats 1ms

/trunk/Lib/chicken/multi-generic.scm

#
Lisp | 152 lines | 109 code | 16 blank | 27 comment | 0 complexity | ad961c68564f1e6d367d96e39fac0a97 MD5 | raw file
  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@nongnu.org or to
 24;; Most code copied from TinyCLOS
 25
 26(define <multi-generic> (make <entity-class>
 27			  'name "multi-generic"
 28			  'direct-supers (list <generic>)
 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 <multi-generic>)
 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 <multi-generic>)
 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 <multi-generic>)
 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 <multi-generic> '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)