Some delayed maintenance.

Fixes for multimodule targets.


git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@6407 626c5289-ae23-0410-ae9c-e8d60b6d4f22

CHANGES.current

@@ -1,6 +1,21 @@
 Version 1.3.23 (in progress)
 ============================
 
+10/17/2004: arty
+	    [OCAML]
+	    - Tweak to enum typing for soundness in the presence of multiple
+	      modules.
+	    - global functions are now unambiguous in multiple loaded modules.
+	    - Fixed test case code to build multimodule test cases correctly.
+	    - There is no way to share overload resolution across modules
+	      because of soundness issues.  If the user wants to call some
+	      function foo from an arbitrary module bar, they will have to
+	      use Bar._foo to call it correctly.  Later I will fix the 
+	      camlp4 module to do something clever in this case.  
+            - Promided performance overhaul of class mechanism.
+	    - Removed symbol hack for ocaml-3.07 and below which is not needed
+	      for ocaml-3.08 and above.
+
 10/16/2004: wuzzeb (John Lenz)
             [CHICKEN]
 	    - Completly change how chicken.cxx handles CLOS and generic code.

Examples/test-suite/imports_a.h

@@ -1,5 +1,8 @@
 enum GlobalEnum { globalenum1=1, globalenum2 };
 
+/* This function should be static as it will be emitted into the code for
+ * every module.  All _static targets would fail here with a multiple 
+ * definition if this is not static. */
 GlobalEnum global_test(GlobalEnum e) { return e; }
 
 class A { 

Examples/test-suite/ocaml/Makefile.in

@@ -13,9 +13,13 @@ top_builddir = @top_builddir@
 C_TEST_CASES = 
 
 run_testcase = \
-	if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ]; then (	  \
+	if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) -a \
+	     -f $(top_srcdir)/Examples/test-suite/$*.list ] ; then ( \
 		ocamlc -c $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX); \
-		ocamlc swig.cmo -custom -g -cc '$(CXX)' -o runme $(srcdir)/$*\.cmo $(srcdir)/$*\_runme.cmo $(srcdir)/$*\_wrap.o  && \
+		ocamlc swig.cmo -custom -g -cc '$(CXX)' -o runme `cat $(top_srcdir)/Examples/test-suite/$(*).list | sed -e 's/\(.*\)/\1_wrap.o \1.cmo/g'`&& ./runme) ; \
+	elif [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ]; then (	  \
+		ocamlc -c $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX); \
+		ocamlc swig.cmo -custom -g -cc '$(CXX)' -o runme $(srcdir)/$(*)_runme.cmo $(srcdir)/$(*)_wrap.o && \
 		./runme) ; \
 	fi ; 
 
@@ -61,10 +65,10 @@ include $(srcdir)/../common.mk
 
 %.multicpptest:
 	echo $@ >> testing
-	$(setup) \
 	($(swig_and_compile_multi_cpp); )  && \
+	$(setup) \
 	$(run_testcase) \
-	if [ -f $(@:%.multicpptest=%_a_wrap.o) ] ; then \
+	if [ -f $(@:%.multicpptest=%_runtime_wrap.o) ] ; then \
 		echo $@ >> success ; \
 	fi
 
@@ -74,4 +78,3 @@ include $(srcdir)/../common.mk
 
 clean:
 	$(MAKE) -f $(top_builddir)/$(EXAMPLES)/Makefile ocaml_clean
-

Lib/ocaml/class.swg

@@ -1,18 +1,39 @@
 (*Stream:class_ctors*)
 let create_$classname_from_ptr raw_ptr =
   C_obj 
-    (let rec invoke_inner raw_ptr mth arg = 
+begin
+  let h = Hashtbl.create 20 in
+    List.iter (fun (nm,fn) -> Hashtbl.replace h nm fn) 
+	[ "nop", (fun args -> C_void) ;
+	  $classbody 
+	 "&", (fun args -> raw_ptr) ;
+       ":parents",
+       (fun args ->
+          C_list
+	  (let out = ref [] in 
+	    Hashtbl.iter (fun x y -> out := (x,y) :: !out) h ;
+          (List.map	
+	     (fun (x,y) ->
+		C_string (String.sub x 2 ((String.length x) - 2)))
+	     (List.filter
+		(fun (x,y) ->
+		   ((String.length x) > 2)
+		   && x.[0] == ':' && x.[1] == ':') !out)))) ;
+       ":classof", (fun args -> C_string "$realname") ;
+       ":methods", (fun args -> 
+	  C_list (let out = ref [] in 
+	    Hashtbl.iter (fun x y -> out := (C_string x) :: !out) h ; !out))
+	] ; 
+	let rec invoke_inner raw_ptr mth arg = 
+	begin
 	  try
-	    let method_name,application = 
+	    let application = Hashtbl.find h mth in
-	      List.hd 
-		(List.filter (fun (x,y) -> x = mth) method_table) in
 	      application
 		(match arg with 
 		     C_list l -> (C_list (raw_ptr :: l)) 
 		   | C_void -> (C_list [ raw_ptr ])
 		   | v -> (C_list [ raw_ptr ; v ]))
-	  with 
+	  with Not_found -> 
-	      (Failure "hd") -> 
 		(* Try parent classes *)
 		begin
 		  let parent_classes = [
@@ -30,30 +51,16 @@ let create_$classname_from_ptr raw_ptr =
 		      | [] ->
 			  raise (BadMethodName (raw_ptr,mth,"$realname"))
 		  in try_parent parent_classes raw_ptr
-		end 
+		end
-     and method_table = [
+	end in
-       "nop", (fun args -> C_void) ;
+	  (fun mth arg -> invoke_inner raw_ptr mth arg)
-       $classbody
+end
-	 "&", (fun args -> raw_ptr) ;
-       ":parents",
-       (fun args ->
-          C_list
-          (List.map
-	     (fun (x,y) ->
-		C_string (String.sub x 2 ((String.length x) - 2)))
-	     (List.filter
-		(fun (x,y) ->
-		   ((String.length x) > 2)
-		   && x.[0] == ':' && x.[1] == ':') method_table))) ;
-       ":classof", (fun args -> C_string "$realname") ;
-       ":methods", (fun args -> C_list (List.map (fun (x,y) -> C_string x)
-					  method_table)) ] in
-       (fun mth arg -> invoke_inner raw_ptr mth arg))
 
 let _ = Callback.register 
           "create_$normalized_from_ptr"
           create_$classname_from_ptr
 
+
 (*Stream:mli*)
 val create_$classname_from_ptr : c_obj -> c_obj
 

Lib/ocaml/mlheading.swg

@@ -1,4 +0,0 @@
-(* -*- tuareg -*- *)
-
-open Swig
-

Lib/ocaml/mliheading.swg

@@ -1,3 +0,0 @@
-(* -*- tuareg -*- *)
-
-open Swig

Lib/ocaml/ocaml.i

@@ -3,10 +3,6 @@
    This file is parsed by SWIG before reading any other interface
    file. */
 
-/* Insert ML/MLI Common stuff */
-%insert(mli) "mliheading.swg"
-%insert(ml) "mlheading.swg"
-
 /* Insert common stuff */
 %insert(runtime) "common.swg"
 

Lib/ocaml/ocaml.swg

@@ -28,6 +28,7 @@ extern "C" {
 #define C_enum 16
 #define C_director_core 17
 
+
 /* Cast a pointer if possible; returns 1 if successful */
     
     SWIGSTATIC int
@@ -242,20 +243,8 @@ extern "C" {
 	    failwith("Need array or list");
     }
 
-#ifdef __cplusplus
-    namespace caml {
-	extern "C"
-#endif 
-	    CAML_VALUE alloc(int,int);
-#ifdef __cplusplus
-    };
-#endif
-
     SWIGSTATIC CAML_VALUE caml_swig_alloc(int x,int y) {
-#ifdef __cplusplus
+	return caml_alloc(x,y);
-	using namespace caml;
-#endif
-	return alloc(x,y);
     }
 
     SWIGSTATIC value caml_array_new( int n ) {
@@ -586,6 +575,16 @@ extern "C" {
 	}	
     }
 
+    static void SWIG_Ocaml_LookupTypePointer() {
+      CAML_VALUE mod_pointer, pointer;
+
+      mod_pointer = caml_val_ptr(swig_type_list_handle, NULL);
+      pointer = callback(*caml_named_value("swig_find_type_info"), mod_pointer);
+      if (SWIG_Tag_val(pointer) == C_ptr) {
+        swig_type_list_handle = (swig_type_info **)(void *)(long)SWIG_Int64_val(SWIG_Field(pointer,0));
+      }
+    }
+
 #ifdef __cplusplus
 }
 #endif

Lib/ocaml/ocamldec.swg

@@ -81,13 +81,7 @@ CAMLextern int64 Int64_val(caml_value_t v);
 #define SWIG_Int64_val(v) Int64_val(v)
 #endif
 
-#if defined(SWIG_NOINCLUDE)
-#	define SWIGSTATIC
-#elif defined(SWIG_GLOBAL)
-#	define SWIGSTATIC
-#else
 #	define SWIGSTATIC static
-#endif
 
 #define SWIG_NewPointerObj(p,type,flags) caml_val_ptr(p,type)
 

Lib/ocaml/preamble.swg

@@ -1,6 +1,4 @@
 %insert(mli) %{
-type c_obj = c_enum_tag c_obj_t
-
 exception BadArgs of string
 exception BadMethodName of c_obj * string * string
 exception NotObject of c_obj
@@ -10,8 +8,6 @@ exception InvalidDirectorCall of c_obj
 %}
 
 %insert(ml) %{
-type c_obj = c_enum_tag c_obj_t
-
 exception BadArgs of string
 exception BadMethodName of c_obj * string * string
 exception NotObject of c_obj

Lib/ocaml/swig.ml

@@ -2,6 +2,8 @@
 open Int32
 open Int64
 
+type enum = [ `Int of int ]
+
 type 'a c_obj_t = 
     C_void
   | C_bool of bool
@@ -23,15 +25,15 @@ type 'a c_obj_t =
   | C_enum of 'a
   | C_director_core of 'a c_obj_t * 'a c_obj_t option ref
 
-type empty_enum = [ `SWIGFake | `Int of int ]
+type c_obj = enum c_obj_t
 
 exception BadArgs of string
 exception BadMethodName of string * string
-exception NotObject of empty_enum c_obj_t
+exception NotObject of c_obj
-exception NotEnumType of empty_enum c_obj_t
+exception NotEnumType of c_obj
-exception LabelNotFromThisEnum of empty_enum c_obj_t
+exception LabelNotFromThisEnum of c_obj
-exception InvalidDirectorCall of empty_enum c_obj_t
+exception InvalidDirectorCall of c_obj
-
+exception NoSuchClass of string
 let rec invoke obj = 
   match obj with 
       C_obj o -> o 
@@ -39,13 +41,8 @@ let rec invoke obj =
     | _ -> raise (NotObject (Obj.magic obj))
 let _ = Callback.register "swig_runmethod" invoke
 
-let fnhelper fin f arg =
+let fnhelper arg =
-  let args = match arg with C_list l -> l | C_void -> [] | _ -> [ arg ] in
+  match arg with C_list l -> l | C_void -> [] | _ -> [ arg ]
-    match f args with
-	[] -> C_void
-      | [ x ] -> (if fin then Gc.finalise 
-		    (fun x -> ignore ((invoke x) "~" C_void)) x) ; x
-      | lst -> C_list lst
 
 let rec get_int x = 
   match x with
@@ -109,8 +106,6 @@ let addr_of obj =
     | _ -> raise (Failure "Not a pointer.")
 let _ = Callback.register "caml_obj_ptr" addr_of
 
-let convert_c_obj a = Obj.magic a
-
 let make_float f = C_float f
 let make_double f = C_double f
 let make_string s = C_string s
@@ -146,3 +141,21 @@ let new_derived_object cfun x_class args =
     ob_ref := Some obj ;
       obj
   end
+  
+let swig_current_type_info = ref C_void
+let find_type_info obj = 
+  match obj with
+    C_ptr _ -> if !swig_current_type_info = C_void 
+                 then begin
+                   swig_current_type_info := obj ;
+                   obj
+                 end else
+                   !swig_current_type_info
+    | _ -> raise (Failure "Internal error: passed non pointer to find_type_info")
+let _ = Callback.register "swig_find_type_info" find_type_info
+
+let class_master_list = Hashtbl.create 20
+let register_class_byname nm co = 
+  Hashtbl.replace class_master_list nm (Obj.magic co)
+let create_class nm arg = 
+  try (Obj.magic (Hashtbl.find class_master_list nm)) arg with _ -> raise (NoSuchClass nm)

Lib/ocaml/swig.mli

@@ -1,4 +1,7 @@
 (* -*- tuareg -*- *)
+
+type enum = [ `Int of int ]
+
 type 'a c_obj_t = 
     C_void
   | C_bool of bool
@@ -20,13 +23,13 @@ type 'a c_obj_t =
   | C_enum of 'a
   | C_director_core of 'a c_obj_t * 'a c_obj_t option ref
 
-type empty_enum = [ `SWIGFake | `Int of int ]
+type c_obj = enum c_obj_t
 
-exception InvalidDirectorCall of empty_enum c_obj_t
+exception InvalidDirectorCall of c_obj
+exception NoSuchClass of string
 
-val invoke : 'a c_obj_t -> (string -> 'a c_obj_t -> 'a c_obj_t)
+val invoke : ('a c_obj_t) -> (string -> 'a c_obj_t -> 'a c_obj_t)
-val convert_c_obj : 'a c_obj_t -> 'b c_obj_t
+val fnhelper : 'a c_obj_t -> 'a c_obj_t list
-val fnhelper : bool -> ('a c_obj_t list -> 'a c_obj_t list) -> 'a c_obj_t -> 'a c_obj_t
 
 val get_int : 'a c_obj_t -> int
 val get_float : 'a c_obj_t -> float
@@ -54,3 +57,5 @@ val new_derived_object:
   ('a c_obj_t -> string -> 'a c_obj_t -> 'a c_obj_t) ->
   'a c_obj_t -> 'a c_obj_t
   
+val register_class_byname : string -> ('a c_obj_t -> 'a c_obj_t) -> unit
+val create_class : string -> 'a c_obj_t -> 'a c_obj_t

Lib/ocaml/typeregister.swg

@@ -3,9 +3,10 @@
   static int       typeinit = 0;
   int       i;
   if (!typeinit) {
+     SWIG_Ocaml_LookupTypePointer();
      for (i = 0; swig_types_initial[i]; i++) {
         swig_types[i] = SWIG_TypeRegister(swig_types_initial[i]);
      }
      typeinit = 1;
   }
-}
+}

Source/Modules/ocaml.cxx

@@ -259,18 +259,19 @@ public:
 	Printf( f_mlbody, "let module_name = \"%s\"\n", module );
 	Printf( f_mlibody, "val module_name : string\n" );
 	Printf( f_enum_to_int, 
-		"let enum_to_int x v =\n"
+		"let enum_to_int x (v : c_obj) =\n"
-		"  match v with C_enum y -> (\n"
+		"   match v with\n"
-		"  match (x : c_enum_type) with\n"
+		"     C_enum _y ->\n"
-		"   `unknown -> "
+		"     (let y = _y in match (x : c_enum_type) with\n"
-		"    (match (y : c_enum_tag) with\n"
+		"       `unknown -> "
-		"      `int (x : int) -> C_int x\n"
+		"         (match (Obj.magic y) with\n"
-		"    | _ -> raise (LabelNotFromThisEnum v))\n" );
+		"           `Int x -> C_int x\n"
+		"           | _ -> raise (LabelNotFromThisEnum v))\n" );
 
 	Printf( f_int_to_enum,
 		"let int_to_enum x y =\n"
 		"    match (x : c_enum_type) with\n"
-		"      `unknown -> C_enum (`int y)\n" );
+		"      `unknown -> C_enum (`Int y)\n" );
 
 	Swig_banner (f_runtime);
 
@@ -281,12 +282,9 @@ public:
     
 	/* Produce the enum_to_int and int_to_enum functions */
     
-	Printf(f_enumtypes_type,"type c_enum_type = [ \n  `unknown\n" );
+	Printf(f_enumtypes_type,"open Swig\n"
-	Printf(f_enumtypes_value,
+	       "type c_enum_type = [ \n  `unknown\n" );
-	       "type c_enum_tag = [\n"
+	Printf(f_enumtypes_value,"type c_enum_value = [ \n  `Int of int\n" );
-	       "  `SWIGFake\n"
-	       "| `int of int\n" );
-    
 	String *mlfile = NewString("");
 	String *mlifile = NewString("");
 
@@ -328,7 +326,8 @@ public:
 		"let _ = f_init ()\n",
 		module, module );
 	Printf( f_enumtypes_type, "]\n" );
-	Printf( f_enumtypes_value, "]\n" );
+	Printf( f_enumtypes_value, "]\n\n"
+		"type c_obj = c_enum_value c_obj_t\n" );
 
 	SwigType_emit_type_table (f_runtime, f_wrappers);
 	/* Close all of the files */
@@ -462,8 +461,11 @@ public:
 	if (overname) {
 	    Append(wname, overname);
 	}
+	/* Do this to disambiguate functions emitted from different modules */
+	Append(wname, module);
+
 	Setattr(n,"wrap:name",wname);
-    
+
 	// Build the name for Scheme.
 	Printv(proc_name,"_",iname,NIL);
 	String *mangled_name = mangleNameForCaml(proc_name);
@@ -731,7 +733,6 @@ public:
 	    if( !Getattr(n,"sym:nextSibling") ) {
 		int maxargs;
 		Wrapper *df = NewWrapper();
-		String *dname = Swig_name_wrapper(iname);
 		String *dispatch = 
 		    Swig_overload_dispatch(n,
 					   "free(argv);\n"
@@ -740,9 +741,15 @@ public:
 
 		Wrapper_add_local(df, "_v", "int _v = 0");
 		Wrapper_add_local(df, "argv", "CAML_VALUE *argv");
+		
+		/* Undifferentiate name .. this is the dispatch function */
+		wname = Swig_name_wrapper(iname);
+		/* Do this to disambiguate functions emitted from different
+		 * modules */
+		Append(wname, module);
 
 		Printv(df->def,
-		       "SWIGEXT CAML_VALUE ",dname,"(CAML_VALUE args) {\n"
+		       "SWIGEXT CAML_VALUE ",wname,"(CAML_VALUE args) {\n"
 		       "  CAMLparam1(args);\n"
 		       "  int i;\n"
 		       "  int argc = caml_list_length(args);\n",NIL);
@@ -756,34 +763,25 @@ public:
 		Printv(df->code,"}\n",NIL);
 		Wrapper_print(df,f_wrappers);
 
-		Printf(f_mlbody, 
-		       "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n"
-		       "let %s = fnhelper %s %s_f\n",
-		       mangled_name, dname, mangled_name, 
-		       newobj ? "true" : "false",
-		       mangled_name );
-		if( !classmode || in_constructor || in_destructor ||
-		    static_member_function ) 
-		    Printf(f_mlibody,
-			   "(* overload *)\n"
-			   "val %s : c_obj -> c_obj\n", mangled_name );
-
 		DelWrapper(df);
 		Delete(dispatch);
-		Delete(dname);
 	    }
-	} else {
-	    Printf(f_mlbody, 
-		   "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n"
-		   "let %s = fnhelper %s %s_f\n",
-		   mangled_name, wname, mangled_name, newobj ? "true" : "false", 
-		   mangled_name );
-	    if( !classmode || in_constructor || in_destructor ||
-		static_member_function ) 
-		Printf(f_mlibody,
-		       "(* Non-overload *)\n"
-		       "val %s : c_obj -> c_obj\n", mangled_name );
 	}
+
+	Printf(f_mlbody, 
+	       "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n"
+	       "let %s arg = match %s_f (fnhelper arg) with\n"
+	       "  [] -> C_void\n"
+	       "| [x] -> (if %s then Gc.finalise \n"
+	       "  (fun x -> ignore ((invoke x) \"~\" C_void)) x) ; x\n"
+	       "| lst -> C_list lst ;;\n",
+	       mangled_name, wname, 
+	       mangled_name, mangled_name, newobj ? "true" : "false");
+	
+	if( !classmode || in_constructor || in_destructor ||
+	    static_member_function ) 
+	    Printf(f_mlibody,
+		   "val %s : c_obj -> c_obj\n", mangled_name );
    
 	Delete(proc_name);
 	Delete(source);
@@ -896,16 +894,15 @@ public:
 	
 	if( Getattr( n, "feature:immutable" ) ) {
 	    Printf( f_mlbody, 
-		    "external __%s : c_obj -> c_obj = \"%s\" \n"
+		    "external _%s : c_obj -> c_obj = \"%s\" \n",
-		    "let _%s = __%s C_void\n",
+		    mname, var_name );
-		    mname, var_name, mname, mname );
+	    Printf( f_mlibody, "val _%s : c_obj -> c_obj\n", iname );
-	    Printf( f_mlibody, "val _%s : c_obj\n", iname );
 	    if( const_enum ) {
 		Printf( f_enum_to_int, 
-			" | `%s -> _%s\n", 
+			" | `%s -> _%s C_void\n", 
 			mname, mname );
 		Printf( f_int_to_enum, 
-			" if y = (get_int _%s) then `%s else\n",
+			" if y = (get_int (_%s C_void)) then `%s else\n",
 			mname, mname );
 	    }
 	} else {
@@ -1194,13 +1191,14 @@ public:
 	  Iterator b;
 	  b = First(baselist);
 	  while (b.item) {
-	    String *bname = Getattr(b.item, "ocaml:ctor");
+	    String *bname = Getattr(b.item, "name");
 	    if (bname) {
+	      String *base_create = NewString("");
+	      Printv(base_create,"(Swig.create_class \"",bname,"\")",NIL);
 	      Printv(f_class_ctors,
-		     "   \"::",bname,"\", (fun args -> "
+		     "   \"::",bname,"\", (fun args -> ",
-		     "create_",bname,"_from_ptr raw_ptr) ;\n",NIL);
+		     base_create," args) ;\n",NIL);
-	      Printv( base_classes, "create_", bname, "_from_ptr ;\n", 
+	      Printv( base_classes, base_create, " ;\n", NIL );
-		      NIL );
 	    }
 	    b = Next(b);
 	  }
@@ -1390,7 +1388,7 @@ public:
 
 	if( oname && !seen_enum ) {
 	    const_enum = true;
-	    Printf( f_enum_to_int, "| `%s -> (match (y : c_enum_tag) with\n", oname );
+	    Printf( f_enum_to_int, "| `%s -> (match (Obj.magic y) with\n", oname );
 	    Printf( f_int_to_enum, "| `%s -> C_enum (\n", oname );
 	    /* * * * A note about enum name resolution * * * *
 	     * This code should now work, but I think we can do a bit better.
@@ -1421,10 +1419,10 @@ public:
 	int ret = Language::enumDeclaration(n);
 	
 	if( const_enum ) {
-	    Printf( f_int_to_enum, "`int y)\n" );
+	    Printf( f_int_to_enum, "`Int y)\n" );
 	    Printf( f_enum_to_int, 
-		    "| `int (x : int) -> C_int x\n"
+		    "| `Int x -> C_int x\n"
-		    "| _ -> raise (Failure \"Unknown enum tag\"))\n" );
+		    "| _ -> raise (LabelNotFromThisEnum v))\n" );
 	}
 
 	const_enum = false;