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

Added class template support (removes text of ocaml class definition from swig

Browse source 
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
This commit is contained in:
Art Yerkes 2003-06-08 03:49:09 +00:00
commit 310751dc48
4 changed files with 132 additions and 98 deletions
Download patch file Download diff file Expand all files Collapse all files

58
SWIG/Lib/ocaml/class.swg Normal file
View file

@ -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

2
SWIG/Lib/ocaml/ocaml.i
View file

@ -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)

7
SWIG/Lib/ocaml/typemaps.i
View file

@ -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);

163
SWIG/Source/Modules/ocaml.cxx
View file

@ -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);