From 310751dc48cd1b94568e2b46ce427e94cccecef9 Mon Sep 17 00:00:00 2001 From: Art Yerkes Date: Sun, 8 Jun 2003 03:49:09 +0000 Subject: [PATCH] Added class template support (removes text of ocaml class definition from swig executable). Now, changes to the implementation of classes can be made without affecting SWIG itself. git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@4872 626c5289-ae23-0410-ae9c-e8d60b6d4f22 --- SWIG/Lib/ocaml/class.swg | 58 ++++++++++++ SWIG/Lib/ocaml/ocaml.i | 2 + SWIG/Lib/ocaml/typemaps.i | 7 +- SWIG/Source/Modules/ocaml.cxx | 163 ++++++++++++++-------------------- 4 files changed, 132 insertions(+), 98 deletions(-) create mode 100644 SWIG/Lib/ocaml/class.swg diff --git a/SWIG/Lib/ocaml/class.swg b/SWIG/Lib/ocaml/class.swg new file mode 100644 index 000000000..253600ce9 --- /dev/null +++ b/SWIG/Lib/ocaml/class.swg @@ -0,0 +1,58 @@ +(*Stream:class_ctors*) +let create_$classname_from_ptr raw_ptr = + C_obj + (let rec method_table = [ + "nop", (fun args -> C_void) ; + $classbody + "&", (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 -> + try + let method_name,application = + 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 + (Failure "hd") -> + (* Try parent classes *) + begin + let parent_classes = [ + $baselist + ] in + let rec try_parent plist raw_ptr = + match plist with + p :: tl -> + begin + try + (invoke (p raw_ptr)) mth arg + with (BadMethodName (p,m,s)) -> + try_parent tl raw_ptr + end + | [] -> + raise (BadMethodName (raw_ptr,mth,"$realname")) + in try_parent parent_classes raw_ptr + end)) + +let _ = Callback.register + "create_$normalized_from_ptr" + create_$classname_from_ptr + +(*Stream:mli*) +val create_$classname_from_ptr : c_obj -> c_obj + diff --git a/SWIG/Lib/ocaml/ocaml.i b/SWIG/Lib/ocaml/ocaml.i index 491da959a..35139f53f 100644 --- a/SWIG/Lib/ocaml/ocaml.i +++ b/SWIG/Lib/ocaml/ocaml.i @@ -20,6 +20,8 @@ %insert(runtime) "ocaml.swg" /*#endif*/ +%insert(classtemplate) "class.swg" + /* Definitions */ #define SWIG_malloc(size) swig_malloc(size, FUNC_NAME) #define SWIG_free(mem) free(mem) diff --git a/SWIG/Lib/ocaml/typemaps.i b/SWIG/Lib/ocaml/typemaps.i index 4f13a4fa0..a56f1c687 100644 --- a/SWIG/Lib/ocaml/typemaps.i +++ b/SWIG/Lib/ocaml/typemaps.i @@ -213,9 +213,11 @@ SIMPLE_MAP(unsigned long long,caml_val_ulong,caml_long_val); %define %char_ptr_in(how) %typemap(how) char *, signed char *, unsigned char * { + /* %typemap(how) char * ... */ $1 = ($ltype)caml_string_val($input); } %typemap(how) char [ANY], signed char [ANY], unsigned char [ANY] { + /* %typemap(how) char [ANY] ... */ char *temp = caml_string_val($input); strncpy((char *)$1,temp,$1_dim0); } @@ -244,10 +246,11 @@ SIMPLE_MAP(unsigned long long,caml_val_ulong,caml_long_val); %define %swigtype_ptr_in(how) %typemap(how) SWIGTYPE * { + /* %typemap(how) SWIGTYPE * */ $1 = ($ltype)caml_ptr_val($input,$1_descriptor); } %typemap(how) SWIGTYPE (CLASS::*) { - /* %typemap(how) SWIGTYPE *, SWIGTYPE (CLASS::*) */ + /* %typemap(how) SWIGTYPE (CLASS::*) */ void *v = caml_ptr_val($input,$1_descriptor); memcpy(& $1, &v, sizeof(v)); } @@ -272,11 +275,9 @@ SIMPLE_MAP(unsigned long long,caml_val_ulong,caml_long_val); %enddef %swigtype_ptr_in(in); -%swigtype_ptr_in(memberin); %swigtype_ptr_in(varin); %swigtype_ptr_in(outv); %swigtype_ptr_out(out); -%swigtype_ptr_out(memberout); %swigtype_ptr_out(varout); %swigtype_ptr_out(inv); diff --git a/SWIG/Source/Modules/ocaml.cxx b/SWIG/Source/Modules/ocaml.cxx index acc664527..ee5bbb623 100755 --- a/SWIG/Source/Modules/ocaml.cxx +++ b/SWIG/Source/Modules/ocaml.cxx @@ -41,6 +41,7 @@ static String *classname=0; static String *module=0; static char *ocaml_path=(char*)"ocaml"; static String *init_func_def = 0; +static String *f_classtemplate = 0; static Hash *seen_enums = 0; static Hash *seen_enumvalues = 0; @@ -415,6 +416,7 @@ public: f_class_ctors_end = NewString(""); f_enum_to_int = NewString(""); f_int_to_enum = NewString(""); + f_classtemplate = NewString(""); module = Getattr(n,"name"); @@ -431,6 +433,8 @@ public: Swig_register_filebyname("ml",f_mlbody); Swig_register_filebyname("director",f_directors); Swig_register_filebyname("director_h",f_directors_h); + Swig_register_filebyname("classtemplate",f_classtemplate); + Swig_register_filebyname("class_ctors",f_class_ctors); Swig_name_register("set","%v__set__"); Swig_name_register("get","%v__get__"); @@ -799,7 +803,8 @@ public: Replaceall(tm,"$target",Getattr(p,"lname")); /* Deprecated */ Replaceall(tm,"$arg",Getattr(p,"emit:input")); Replaceall(tm,"$input",Getattr(p,"emit:input")); - Replaceall(tm,"$ntype",normalizeTemplatedClassName(Getattr(p,"type"))); + Replaceall(tm,"$ntype", + normalizeTemplatedClassName(Getattr(p,"type"))); Printv(outarg,tm,"\n",NIL); p = Getattr(p,"tmap:argout:next"); argout_set = 1; @@ -1214,6 +1219,38 @@ public: return ret; } + /** + * A simple, somewhat general purpose function for writing to multiple + * streams from a source template. This allows the user to define the + * class definition in ways different from the one I have here if they + * want to. It will also make the class definition system easier to + * fiddle with when I want to change methods, etc. + */ + + void Multiwrite( String *s ) { + char *find_marker = strstr(Char(s),"(*Stream:"); + while( find_marker ) { + char *next = strstr(find_marker,"*)"); + find_marker += strlen("(*Stream:"); + + if( next ) { + int num_chars = next - find_marker; + String *stream_name = NewString(find_marker); + Delslice(stream_name,num_chars,Len(stream_name)); + File *fout = Swig_filebyname(stream_name); + if( fout ) { + next += strlen("*)"); + char *following = strstr(next,"(*Stream:"); + find_marker = following; + if( !following ) following = next + strlen(next); + String *chunk = NewString(next); + Delslice(chunk,following-next,Len(chunk)); + Printv(fout,chunk,NIL); + } + } + } + } + /* classHandler * * Create a "class" definition for ocaml. I thought quite a bit about @@ -1286,115 +1323,51 @@ public: int classHandler( Node *n ) { String *name = Getattr(n,"name"); String *mangled_sym_name = mangleNameForCaml(name); - + String *this_class_def = NewString( f_classtemplate ); + String *classbody = NewString(""); + String *name_normalized = normalizeTemplatedClassName(name); + String *old_class_ctors = f_class_ctors; + String *base_classes = NewString(""); + f_class_ctors = NewString(""); + if( !name ) return SWIG_OK; classname = mangled_sym_name; - - Printf( f_class_ctors, - "let create_%s_from_ptr raw_ptr =\n" - " C_obj (let rec method_table = [\n" - " \"nop\", (fun args -> C_void) ;\n", - classname ); - - Printf( f_mlibody, - "val create_%s_from_ptr : c_obj -> c_obj\n", - classname ); - - // Actually write out the class definition - - classmode = 1; + classmode = true; int rv = Language::classHandler(n); - classmode = 0; + classmode = false; -#if 0 - Printf(f_mlibody, - "val delete_%s : c_obj -> unit\n", - mangled_sym_name ); -#endif - /* Handle up-casts in a nice way */ List *baselist = Getattr(n,"bases"); if (baselist && Len(baselist)) { Node *base = Firstitem(baselist); while (base) { String *bname = Getattr(base, "ocaml:ctor"); - if (bname) - Printv(f_class_ctors, + if (bname) { + Printv(classbody, " \"::",bname,"\", (fun args -> " "create_",bname,"_from_ptr raw_ptr) ;\n",NIL); - - base = Nextitem(baselist); - } - } - - Printf(f_class_ctors, - " \"&\", (fun args -> raw_ptr) ;\n" - " \":parents\",\n" - " (fun args -> \n" - " C_list \n" - " (List.map \n" - " (fun (x,y) -> \n" - " C_string (String.sub x 2 ((String.length x) - 2)))\n" - " (List.filter \n" - " (fun (x,y) -> \n" - " ((String.length x) > 2) && \n" - " x.[0] == ':' && \n" - " x.[1] == ':') method_table))) ;\n" - " \":classof\", (fun args -> (C_string \"%s\")) ;\n" - " \":methods\", " - "(fun args -> C_list (List.map (fun (x,y) -> C_string x) " - "method_table)) ] in\n" - " (fun mth arg ->\n" - " try\n" - " let method_name,application = List.hd (List.filter (fun (x,y) -> x = mth) method_table) in\n" - " application \n" - " (match arg with C_list l -> (C_list (raw_ptr :: l)) | C_void -> (C_list [ raw_ptr ]) | v -> (C_list [ raw_ptr ; v ]))\n" - " with (Failure \"hd\") -> \n" - " (* Try parent classes *)\n" - " begin\n" - " let parent_classes = [ \n", - name ); - - /* Handle inheritance -- Mostly stolen from python code */ - baselist = Getattr(n,"bases"); - if (baselist && Len(baselist)) { - Node *base = Firstitem(baselist); - while (base) { - String *bname = Getattr(base, "ocaml:ctor"); - if (bname) - Printv(f_class_ctors, - " create_",bname,"_from_ptr",NIL); - - base = Nextitem(baselist); - if (base) - Printv(f_class_ctors," ;\n",NIL); - else - Printv(f_class_ctors,"\n",NIL); - } - } - - Printv(f_class_ctors," ]\n",NIL); - - Printf(f_class_ctors, - " in let rec try_parent plist raw_ptr = \n" - " match plist with\n" - " p :: tl -> (try\n" - " (invoke (p raw_ptr)) mth arg\n" - " with (BadMethodName (p,m,s)) -> try_parent tl raw_ptr)\n" - " | [] ->\n" - " raise (BadMethodName (raw_ptr,mth,\"%s\"))\n" - " in try_parent parent_classes raw_ptr\n" - " end\n" - " | e -> raise e))\n", - name ); + Printv( base_classes, "create_", bname, "_from_ptr ;\n", + NIL ); + } - String *name_normalized = normalizeTemplatedClassName(name); + base = Nextitem(baselist); + } + } - Printf( f_class_ctors, - "let _ = Callback.register \"create_%s_from_ptr\" " - "create_%s_from_ptr\n", - name_normalized, classname ); + Replaceall(this_class_def,"$classname",classname); + Replaceall(this_class_def,"$classbody",classbody); + Replaceall(this_class_def,"$normalized",name_normalized); + Replaceall(this_class_def,"$realname",name); + Replaceall(this_class_def,"$baselist",base_classes); + Replaceall(this_class_def,"$classbody",f_class_ctors); + + Delete(f_class_ctors); + f_class_ctors = old_class_ctors; + + // Actually write out the class definition + + Multiwrite( this_class_def ); Setattr(n,"ocaml:ctor",classname);