[OpenSPARC-T2-SAM] / sam-t2 / devtools / v8plus / share / swig / 1.3.26 / chicken / multi-generic.scm

;; This file overrides two functions inside TinyCLOS to provide support
;; for multi-argument generics.  There are many ways of linking this file
;; into your code... all that needs to happen is this file must be
;; executed after loading TinyCLOS but before any SWIG modules are loaded
;;
;; something like the following
;; (require 'tinyclos)
;; (load "multi-generic")
;; (declare (uses swigmod))
;;
;; An alternative to loading this scheme code directly is to add a
;; (declare (unit multi-generic)) to the top of this file, and then
;; compile this into the final executable or something.  Or compile
;; this into an extension.

;; Lastly, to override TinyCLOS method creation, two functions are
;; overridden: see the end of this file for which two are overridden.
;; You might want to remove those two lines and then exert more control over
;; which functions are used when.

;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to
;; Author: John Lenz <lenz@cs.wisc.edu>, most code copied from TinyCLOS

(define <multi-generic> (make <entity-class>
			  'name "multi-generic"
			  'direct-supers (list <generic>)
			  'direct-slots '()))

(letrec ([applicable?
          (lambda (c arg)
            (memq c (class-cpl (class-of arg))))]

         [more-specific?
          (lambda (c1 c2 arg)
            (memq c2 (memq c1 (class-cpl (class-of arg)))))]

         [filter-in
           (lambda (f l)
             (if (null? l)
                 '()
                 (let ([h (##sys#slot l 0)]
	               [r (##sys#slot l 1)] )
	           (if (f h)
	               (cons h (filter-in f r))
	               (filter-in f r) ) ) ) )])

(add-method compute-apply-generic
  (make-method (list <multi-generic>)
    (lambda (call-next-method generic)
      (lambda args
		(let ([cam (let ([x (compute-apply-methods generic)]
				 [y ((compute-methods generic) args)] )
			     (lambda (args) (x y args)) ) ] )
		  (cam args) ) ) ) ) )


(add-method compute-methods
  (make-method (list <multi-generic>)
    (lambda (call-next-method generic)
      (lambda (args)
	(let ([applicable
	       (filter-in (lambda (method)
                            (let check-applicable ([list1 (method-specializers method)]
                                                   [list2 args])
                              (cond ((null? list1) #t)
                                    ((null? list2) #f)
                                    (else
                                      (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
                                           (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
			  (generic-methods generic) ) ] )
	  (if (or (null? applicable) (null? (##sys#slot applicable 1))) 
	      applicable
	      (let ([cmms (compute-method-more-specific? generic)])
		(sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )

(add-method compute-method-more-specific?
  (make-method (list <multi-generic>)
    (lambda (call-next-method generic)
      (lambda (m1 m2 args)
	(let loop ((specls1 (method-specializers m1))
		   (specls2 (method-specializers m2))
		   (args args))
	  (cond-expand
	   [unsafe
	    (let ((c1  (##sys#slot specls1 0))
		  (c2  (##sys#slot specls2 0))
		  (arg (##sys#slot args 0)))
	      (if (eq? c1 c2)
		  (loop (##sys#slot specls1 1)
			(##sys#slot specls2 1)
			(##sys#slot args 1))
		  (more-specific? c1 c2 arg))) ] 
	   [else
	    (cond ((and (null? specls1) (null? specls2))
		   (##sys#error "two methods are equally specific" generic))
		  ;((or (null? specls1) (null? specls2))
		  ; (##sys#error "two methods have different number of specializers" generic))
                  ((null? specls1) #f)
                  ((null? specls2) #t)
		  ((null? args)
		   (##sys#error "fewer arguments than specializers" generic))
		  (else
		   (let ((c1  (##sys#slot specls1 0))
			 (c2  (##sys#slot specls2 0))
			 (arg (##sys#slot args 0)))
		     (if (eq? c1 c2)
			 (loop (##sys#slot specls1 1)
			       (##sys#slot specls2 1)
			       (##sys#slot args 1))
			 (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) )

) ;; end of letrec

(define multi-add-method
  (lambda (generic method)
    (slot-set!
     generic
     'methods
       (let filter-in-method ([methods (slot-ref generic 'methods)])
         (if (null? methods)
           (list method)
           (let ([l1 (length (method-specializers method))]
		 [l2 (length (method-specializers (##sys#slot methods 0)))])
             (cond ((> l1 l2)
                    (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
                   ((< l1 l2)
                    (cons method methods))
                   (else
                     (let check-method ([ms1 (method-specializers method)]
                                        [ms2 (method-specializers (##sys#slot methods 0))])
                       (cond ((and (null? ms1) (null? ms2))
                              (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
                             ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
                              (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
                             (else
                               (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))

    (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) ))

(define (multi-add-global-method val sym specializers proc)
  (let ((generic (if (procedure? val) val (make <multi-generic> 'name (##sys#symbol->string sym)))))
    (multi-add-method generic (make-method specializers proc))
    generic))

;; Might want to remove these, or perhaps do something like
;; (define old-add-method ##tinyclos#add-method)
;; and then you can switch between creating multi-generics and TinyCLOS generics.
(set! ##tinyclos#add-method multi-add-method)
(set! ##tinyclos#add-global-method multi-add-global-method)
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)