diff options
author | John Lenz <jlenz2@math.uiuc.edu> | 2005-04-07 00:39:28 +0000 |
---|---|---|
committer | John Lenz <jlenz2@math.uiuc.edu> | 2005-04-07 00:39:28 +0000 |
commit | 56ac2ae4b11ad213f23fcc9a5c33d5e57399b38e (patch) | |
tree | cffcb8c835313ffc6523eb12609fc0b87f154cd0 | |
parent | 211ddefb74a995f467ce71b062425ae18c0dde52 (diff) | |
download | swig-56ac2ae4b11ad213f23fcc9a5c33d5e57399b38e.tar.gz |
Add some chicken test-suite entries for overloaded functions
(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
-rw-r--r-- | Doc/Manual/Chicken.html | 33 | ||||
-rw-r--r-- | Examples/test-suite/chicken/overload_copy_runme_proxy.ss | 8 | ||||
-rw-r--r-- | Examples/test-suite/chicken/overload_extend_runme_proxy.ss | 16 | ||||
-rw-r--r-- | Examples/test-suite/chicken/overload_simple_runme_proxy.ss | 38 | ||||
-rw-r--r-- | Examples/test-suite/chicken/overload_subtype_runme_proxy.ss | 12 | ||||
-rw-r--r-- | Examples/test-suite/overload_simple.i | 13 | ||||
-rw-r--r-- | Lib/chicken/extra-install.list | 2 | ||||
-rw-r--r-- | Lib/chicken/multi-generic.scm | 150 | ||||
-rw-r--r-- | Lib/chicken/tinyclos-multi-generic.patch | 82 | ||||
-rw-r--r-- | Source/Modules/chicken.cxx | 8 |
10 files changed, 348 insertions, 14 deletions
diff --git a/Doc/Manual/Chicken.html b/Doc/Manual/Chicken.html index 0ef9bc34d..2aaab3a47 100644 --- a/Doc/Manual/Chicken.html +++ b/Doc/Manual/Chicken.html @@ -543,7 +543,40 @@ all the modules.</p> <ul> <li>No director support.</li> <li>No support for c++ standard types like std::vector.</li> + <li>The TinyCLOS wrappers for overloaded functions will not work correctly when using + <a href="SWIGPlus.html#SWIGPlus_default_args">%feature(compactdefaultargs)</a>.</li> </ul> + <p>TinyCLOS has a limitation such that generic methods do not properly work on methods + with different number of specializers: TinyCLOS assumes that every method added to a generic function + will have the same number of specializers. SWIG generates functions with different lengths of specializers + when C/C++ functions are overloaded. For example, the code</p> + +<div class="code"> +<pre> +class Foo {}; +int foo(int a, Foo *b); +int foo(int a); +</pre></div> + +<p>will produce scheme code</p> + +<div class="targetlang"> +<pre> +(define-method (foo (arg0 <top>) (arg1 <Foo>)) (<i>call primitive function</i>)) +(define-method (foo (arg0 <top>)) (<i>call primitive function</i>)) +</pre></div> + +<p>Using unpatched TinyCLOS, the second <code>(define-method)</code> will replace the first one, +so calling <code>(foo 3 f)</code> will produce an error.</p> + +<p>There are two solutions to this: the +file <tt>Lib/chicken/tinyclos-multi-generic.patch</tt> in the SWIG source contains a patch against +tinyclos.scm inside the chicken source to add support into TinyCLOS for multi-argument generics. +This requires chicken to be rebuilt and custom install of chicken. An alternative is the <tt>Lib/chicken/multi-generic.scm</tt> +file in the SWIG source. This file can be loaded after TinyCLOS is loaded, and it will override some functions +inside TinyCLOS to correctly support multi-argument generics. This solution will work on any install of chicken. +Please see the comments at the top of both files for more information.</p> + </body> </html> diff --git a/Examples/test-suite/chicken/overload_copy_runme_proxy.ss b/Examples/test-suite/chicken/overload_copy_runme_proxy.ss new file mode 100644 index 000000000..ec4ddd201 --- /dev/null +++ b/Examples/test-suite/chicken/overload_copy_runme_proxy.ss @@ -0,0 +1,8 @@ +(require 'tinyclos) +(load "../../../Lib/chicken/multi-generic.scm") +(load-library 'overload-copy "./overload_copy.so") + +(define f (make <Foo>)) +(define g (make <Foo> f)) + +(exit 0) diff --git a/Examples/test-suite/chicken/overload_extend_runme_proxy.ss b/Examples/test-suite/chicken/overload_extend_runme_proxy.ss new file mode 100644 index 000000000..04c186a1d --- /dev/null +++ b/Examples/test-suite/chicken/overload_extend_runme_proxy.ss @@ -0,0 +1,16 @@ +(require 'tinyclos) +(load "../../../Lib/chicken/multi-generic.scm") +(load-library 'overload-extend "./overload_extend.so") + +(define f (make <Foo>)) + +(if (not (= (test f 3) 1)) + (error "test integer bad")) + +(if (not (= (test f "hello") 2)) + (error "test string bad")) + +(if (not (= (test f 3.5 2.5) 6.0)) + (error "test reals bad")) + +(exit 0) diff --git a/Examples/test-suite/chicken/overload_simple_runme_proxy.ss b/Examples/test-suite/chicken/overload_simple_runme_proxy.ss index 9c401f556..fa58f267e 100644 --- a/Examples/test-suite/chicken/overload_simple_runme_proxy.ss +++ b/Examples/test-suite/chicken/overload_simple_runme_proxy.ss @@ -1,24 +1,46 @@ +(require 'tinyclos) +(load "../../../Lib/chicken/multi-generic.scm") (load-library 'overload_simple "overload_simple.so") (define-macro (check test) - `(if (not ,test) (error ,'test))) + `(if (not ,test) (error ',test))) +(check (string=? (foo) "foo:")) (check (string=? (foo 3) "foo:int")) -(exit 0) (check (string=? (foo 3.01) "foo:double")) (check (string=? (foo "hey") "foo:char *")) (define f (make <Foo>)) (define b (make <Bar>)) -(define s (make <Spam>)) +(define b2 (make <Bar> 3)) + +(check (= (slot-ref b 'num) 0)) +(check (= (slot-ref b2 'num) 3)) (check (string=? (foo f) "foo:Foo *")) (check (string=? (foo b) "foo:Bar *")) +(check (string=? (foo f 3) "foo:Foo *,int")) +(check (string=? (foo 3.2 b) "foo:double,Bar *")) ;; now check blah (check (string=? (blah 2.01) "blah:double")) (check (string=? (blah "hey") "blah:char *")) +;; now check spam member functions +(define s (make <Spam>)) +(define s2 (make <Spam> 3)) +(define s3 (make <Spam> 3.2)) +(define s4 (make <Spam> "whee")) +(define s5 (make <Spam> f)) +(define s6 (make <Spam> b)) + +(check (string=? (slot-ref s 'type) "none")) +(check (string=? (slot-ref s2 'type) "int")) +(check (string=? (slot-ref s3 'type) "double")) +(check (string=? (slot-ref s4 'type) "char *")) +(check (string=? (slot-ref s5 'type) "Foo *")) +(check (string=? (slot-ref s6 'type) "Bar *")) + ;; now check Spam member functions (check (string=? (foo s 2) "foo:int")) (check (string=? (foo s 2.1) "foo:double")) @@ -27,10 +49,10 @@ (check (string=? (foo s b) "foo:Bar *")) ;; check static member funcs -(check (string=? (bar 3) "bar:int")) -(check (string=? (bar 3.2) "bar:double")) -(check (string=? (bar "hey") "bar:char *")) -(check (string=? (bar f) "bar:Foo *")) -(check (string=? (bar b) "bar:Bar *")) +(check (string=? (Spam-bar 3) "bar:int")) +(check (string=? (Spam-bar 3.2) "bar:double")) +(check (string=? (Spam-bar "hey") "bar:char *")) +(check (string=? (Spam-bar f) "bar:Foo *")) +(check (string=? (Spam-bar b) "bar:Bar *")) (exit 0) diff --git a/Examples/test-suite/chicken/overload_subtype_runme_proxy.ss b/Examples/test-suite/chicken/overload_subtype_runme_proxy.ss new file mode 100644 index 000000000..74fb7de3f --- /dev/null +++ b/Examples/test-suite/chicken/overload_subtype_runme_proxy.ss @@ -0,0 +1,12 @@ +(load-library 'overload-subtype "./overload_subtype.so") + +(define f (make <Foo>)) +(define b (make <Bar>)) + +(if (not (= (spam f) 1)) + (error "Error in foo")) + +(if (not (= (spam b) 2)) + (error "Error in bar")) + +(exit 0) diff --git a/Examples/test-suite/overload_simple.i b/Examples/test-suite/overload_simple.i index bdcd7d5e5..8a4ce565e 100644 --- a/Examples/test-suite/overload_simple.i +++ b/Examples/test-suite/overload_simple.i @@ -11,11 +11,16 @@ struct Foo { class Bar { public: - Bar(int i = 0) {} + Bar(int i = 0) { num = i; } static int foo(int a=0, int b=0) {return 0;} + + int num; }; +char *foo() { + return (char *) "foo:"; +} char *foo(int) { return (char*) "foo:int"; } @@ -37,6 +42,12 @@ char *foo(Bar *) { char *foo(void *) { return (char *) "foo:void *"; } +char *foo(Foo *, int) { + return (char *) "foo:Foo *,int"; +} +char *foo(double, Bar *) { + return (char *) "foo:double,Bar *"; +} char *blah(double) { return (char *) "blah:double"; diff --git a/Lib/chicken/extra-install.list b/Lib/chicken/extra-install.list index 8962be42c..48721cee0 100644 --- a/Lib/chicken/extra-install.list +++ b/Lib/chicken/extra-install.list @@ -1 +1,3 @@ swigclosprefix.scm +multi-generic.scm +tinyclos-multi-generic.patch diff --git a/Lib/chicken/multi-generic.scm b/Lib/chicken/multi-generic.scm new file mode 100644 index 000000000..a1a5c369e --- /dev/null +++ b/Lib/chicken/multi-generic.scm @@ -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) diff --git a/Lib/chicken/tinyclos-multi-generic.patch b/Lib/chicken/tinyclos-multi-generic.patch new file mode 100644 index 000000000..2a85f1a63 --- /dev/null +++ b/Lib/chicken/tinyclos-multi-generic.patch @@ -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: diff --git a/Source/Modules/chicken.cxx b/Source/Modules/chicken.cxx index f7d189c70..b51fac880 100644 --- a/Source/Modules/chicken.cxx +++ b/Source/Modules/chicken.cxx @@ -1057,8 +1057,7 @@ CHICKEN::classHandler(Node *n) if (have_constructor) { Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", - " (call-next-method)\n", - " (swig-initialize obj initargs ", NIL); + " (swig-initialize obj initargs ", NIL); if (constructor_arg_types) { String *initfunc_name = NewStringf("%s@@SWIG@initmethod", class_name); String *func_call = buildClosFunctionCall(constructor_arg_types, initfunc_name, chickenPrimitiveName(constructor_name)); @@ -1080,9 +1079,8 @@ CHICKEN::classHandler(Node *n) constructor_name = 0; } else { Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", - " (call-next-method)\n", - " (swig-initialize obj initargs (lambda x #f)))\n", - NIL); + " (swig-initialize obj initargs (lambda x #f)))\n", + NIL); } /* export class initialization function */ |