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

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 &lt;top&gt;) (arg1 &lt;Foo&gt;)) (<i>call primitive function</i>))
+(define-method (foo (arg0 &lt;top&gt;)) (<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>

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)

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)

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)

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)

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";

Lib/chicken/extra-install.list

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

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)

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:

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 */