jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add some chicken test-suite entries for overloaded functions

Browse source 
(which now work correctly) and update the chicken documentation


git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@7146 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
John Lenz 2005-04-07 00:39:28 +00:00
commit 56ac2ae4b1
10 changed files with 348 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Lib/chicken/extra-install.list
View file

@ -1 +1,3 @@
swigclosprefix.scm
multi-generic.scm
tinyclos-multi-generic.patch

150
Lib/chicken/multi-generic.scm Normal file
View file

@ -0,0 +1,150 @@
;; 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)

82
Lib/chicken/tinyclos-multi-generic.patch Normal file
View file

@ -0,0 +1,82 @@
# This patch is against chicken 1.92, but it should work just fine
# with older versions of chicken. It adds support for mulit-argument
# generics, that is, generics now correctly handle adding methods
# with different lengths of specializer lists
# Comments, bugs, suggestions send to chicken-users@nongnu.org
# Patch written by John Lenz <lenz@cs.wisc.edu>
--- tinyclos.scm.old 2005-04-04 23:35:10.000000000 -0500
+++ tinyclos.scm 2005-04-05 14:03:26.740306763 -0500
@@ -868,13 +868,24 @@
(##tinyclos#slot-set!
generic
'methods
- (cons method
- (filter-in
- (lambda (m)
- (let ([ms1 (method-specializers m)]
- [ms2 (method-specializers method)] )
- (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) )
- (##tinyclos#slot-ref generic 'methods))))
+ (let filter-in-method ([methods (##tinyclos#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))))))))))))
(if (memq generic generic-invocation-generics)
(set! method-cache-tag (vector))
(%entity-cache-set! generic #f) )
@@ -946,9 +957,13 @@
(lambda (args)
(let ([applicable
(filter-in (lambda (method)
- (every2 applicable?
- (method-specializers method)
- args))
+ (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
@@ -975,8 +990,10 @@
[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))
+ ;((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
@@ -1235,7 +1252,7 @@
(define <tcp-listener> (make-primitive-class "tcp-listener" <structure>))
(define <c++-object> (make <class> 'name "c++-object" 'direct-supers (list <object>) 'direct-slots '(this)))
-(set! method-caching-enabled #t)
+;(set! method-caching-enabled #t)
;;; Utilities: