Commits

camlspotter committed 0aedc20 Merge

merge with dev

Comments (0)

Files changed (31)

 ^auto\.(idl|ml|mli)$
 ^.*\.idl$
 ^auto_stubs\.c$
+autoapi\.mlp$
 autoapi\.ml$
 autoclasses.*$
 test$
 PY_PREFIX=/usr
 PY_VERSION=2.7
 CFLAGS+= -fPIC -I $(OCAML_WHERE) -I $(PY_PREFIX)/include/python$(PY_VERSION)
+OCAMLFLAGS+= -warn-error A-31
 
 # I (jfuruse) install camlidl using findlib, but not for the others.
 CAMLIDL_FINDLIB=$(OCAMLFIND_DESTDIR)/camlidl
 autoapi.ml : auto.ml module.pl $(addsuffix .idl.in, $(IDLS))
     ./module.pl *.idl.in > $@
 
+api.auto.mli: api.cmi api.ml
+
+OOApiauto.ml: api.auto.mli oowrap/oowrap.cmo
+    camlp4o ./oowrap/oowrap.cmo api.auto.mli -printer Camlp4OCamlPrinter > $@
+
 auto_stubs.o: auto_stubs.c auto.h api_ml.h autoclasses.h
 
 clean:
   rm -f $(filter-proper-targets $(ls R, .))
 
 MyOCamlPackageExtras[] = opycaml_python.o from_python_c.o
-MyOCamlPackage(opycaml, utils type autoapi api, auto_stubs api_ml, -lpython$(PY_VERSION) -L$(PREFIX)/lib/ocaml $(L_CAMLIDL_FINDLIB) -lcamlidl)
+MyOCamlPackage(opycaml, utils type autoapi api OOApiauto OOApi, auto_stubs api_ml, -lpython$(PY_VERSION) -L$(PREFIX)/lib/ocaml $(L_CAMLIDL_FINDLIB) -lcamlidl)
 
 opycaml_python.o: opycaml.cmx libopycaml.a dllopycaml.so
 	$(OCamlOpt) -output-obj -o $@ opycaml.cmx -cclib -lopycaml -ccopt -L$(OCAML_WHERE) $(CCOPT_L_CAMLIDL_FINDLIB) -ccopt -Wl,-rpath,$(OCAML_WHERE) -cclib -lpython$(PY_VERSION) -cclib -lcamlidl
 OCamlProgram(test, test)
 OCamlProgram(test_bug1, test_bug1)
 
-.SUBDIRS: tests pa
+.SUBDIRS: tests oowrap
 
+module OPy = struct
+  include OOApiauto
+end
+
+open OPy
+module Slice = Slice
+module Mapping = Mapping
+module Tuple = Tuple
+module Err = Err
+module Number = Number
+module ByteArray = ByteArray
+module Index = Index
+(* module String = *)
+module CObject = CObject
+module Base = Base
+module Import = Import
+module Eval = Eval
+module Run = Run
+module Closure = Closure
+module Mutable = Mutable
+(* module List =  *)
+module Sequence = Sequence
+module Module = Module
+module Object = Object
+module Float = Float
+module Type = Type
+module Class = Class
+module Long = Long
+module Iter = Iter
+module Dict = Dict
+module Int = Int
+module Integral = Integral
+module Unicode = Unicode
+module DictProxy = DictProxy
+module Callable = Callable
+module None = None
 include Type
 
-open Autoapi
-
 module Py = struct
   module OCaml = struct
     module String = String
     module Callback = Callback
+    module List = List
   end
     
+  open Autoapi
+
   module String = String
   module ByteArray = ByteArray
   module Number = Number
       val to_list : _Tuple t -> _Object t list
     end = struct
       let from_list lst =
-	let tpl = new_ (List.length lst) in
-	Utils.List.iteri (setItem tpl) lst;
+	let tpl = new_ (OCaml.List.length lst) in
+	Utils.List.iteri (setItemPos tpl) lst;
 	tpl
   
       let to_list a =
 	let len = _GET_SIZE a in
 	let rec f st = function
           | -1 -> st
-          | n -> f (getItem a n :: st) (n-1)
+          | n -> f (getItemPos a n :: st) (n-1)
 	in
 	f [](len-1)
     end
         Printf.eprintf "%s : %d : %nx : %s\n%!" name cnt address repr
     
       external _main : int -> string list -> int = "opycaml_Py_Main"
-      let main argv = _main (List.length argv) argv
+      let main argv = _main (OCaml.List.length argv) argv
 
       external unsafe_embed : 'a -> _CObject t = "opycaml_embed_ocaml_value"
       external unsafe_extract : _CObject t -> 'a = "opycaml_extract_embeded_ocaml_value"
 [new] PyByteArrayObject* PyByteArray_FromStringAndSize([string] const char *string, Py_ssize_t len);
 //    Create a new bytearray object from string and its length, len. On failure, NULL is returned.
 
-[new] PyByteArrayObject* PyByteArray_Concat(PyByteArrayObject *a, PyByteArrayObject *b);
+[new] PyByteArrayObject* PyByteArray_Concat(PyByteArrayObject *a, PyByteArrayObject *b); [mlname concatByteArray]
 //    Concat bytearrays a and b and return a new bytearray with the result.
 
 size_or_fail PyByteArray_Size(PyByteArrayObject *bytearray);
 unit_or_fail PyDict_DelItem(PyDictObject *p, PyObject *key);
 // Remove the entry in dictionary p with key key. key must be hashable; if it isn’t, TypeError is raised. Return 0 on success or -1 on failure.
 
-int PyDict_DelItemString(PyDictObject *p, [string] char *key);
+unit_or_fail PyDict_DelItemString(PyDictObject *p, [string] char *key);
 // Remove the entry in dictionary p which has a key specified by the string key. Return 0 on success or -1 on failure.
 
 PyObject* PyDict_GetItem(PyDictObject *p, PyObject *key);
 // Return value: Borrowed reference.
 // This is the same as PyDict_GetItem(), but key is specified as a char*, rather than a PyObject*.
 
-[new] PyObject* PyDict_Items(PyDictObject *p);
+[new] PyListObject* PyDict_Items(PyDictObject *p);
 // Return value: New reference.
 // Return a PyListObject containing all the items from the dictionary, as in the dictionary method dict.items().
 
-[new] PyObject* PyDict_Keys(PyDictObject *p);
+[new] PyListObject* PyDict_Keys(PyDictObject *p);
 // Return value: New reference.
 // Return a PyListObject containing all the keys from the dictionary, as in the dictionary method dict.keys().
 
-[new] PyObject* PyDict_Values(PyDictObject *p);
+[new] PyListObject* PyDict_Values(PyDictObject *p);
 // Return value: New reference.
 // Return a PyListObject containing all the values from the dictionary p, as in the dictionary method dict.values().
 

example/OMakefile

-USE_OCAMLFIND=true
-
-OCAMLPACKS = opycaml
-
-.DEFAULT: $(OCamlProgram test, test)
-.DEFAULT: $(OCamlProgram module_new, module_new)
-
-.PHONY: clean
-clean:
-  rm -f $(filter-proper-targets $(ls R, .))

example/OMakeroot

-########################################################################
-# Permission is hereby granted, free of charge, to any person
-# obtaining a copy of this file, to deal in the File without
-# restriction, including without limitation the rights to use,
-# copy, modify, merge, publish, distribute, sublicense, and/or
-# sell copies of the File, and to permit persons to whom the
-# File is furnished to do so, subject to the following condition:
-#
-# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
-# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
-# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
-# THE USE OR OTHER DEALINGS IN THE FILE.
-
-########################################################################
-# The standard OMakeroot file.
-# You will not normally need to modify this file.
-# By default, your changes should be placed in the
-# OMakefile in this directory.
-#
-# If you decide to modify this file, note that it uses exactly
-# the same syntax as the OMakefile.
-#
-
-#
-# Include the standard installed configuration files.
-# Any of these can be deleted if you are not using them,
-# but you probably want to keep the Common file.
-#
-open build/C
-open build/OCaml
-open build/LaTeX
-
-#
-# The command-line variables are defined *after* the
-# standard configuration has been loaded.
-#
-DefineCommandVars()
-
-#
-# Include the OMakefile in this directory.
-#
-.SUBDIRS: .

example/module_new.ml

-open Opycaml.Api
-
-let _ =
-  Base.initialize ();
-  let mdl = Module.new_ "MyModule" in
-  let mdldic = Import.getModuleDict () in
-  Dict.setItemString mdldic "MyModule" mdl;
-  let dic = Module.getDict mdl in
-  Dict.setItemString dic "answer" (Int.fromLong 42);
-  ignore (Base.main []);
-  Base.finalize ()
-;;
-
-
-  

example/test.ml

-(* open Opycaml.Api is recommended. *)
-open Opycaml.Api
-
-let _ =
-  Base.initialize ();
-
-  let string = Import.importModule "string" in (* from string import * *)
-  let dict = Module.getDict string in
-  let lowercase = Dict.getItemString dict "lowercase" in
-  let capitalize = Dict.getItemString dict "capitalize" in
-
-  let res = Object.callObject (Callable.coerce capitalize) [lowercase] in
-
-  (* String class is not accessible by String but Py.String, in order
-     to avoid the name space collision with String in OCaml standard
-     library. *)
-  prerr_endline (Py.String.asString (Py.String.coerce res));
-
-  Base.finalize ()
-;;

examples/OMakefile

+USE_OCAMLFIND=true
+
+OCAMLPACKS = opycaml
+
+.DEFAULT: $(OCamlProgram test, test)
+.DEFAULT: $(OCamlProgram module_new, module_new)
+.DEFAULT: $(OCamlProgram testoo, testoo)
+
+.PHONY: clean
+clean:
+  rm -f $(filter-proper-targets $(ls R, .))

examples/OMakeroot

+########################################################################
+# Permission is hereby granted, free of charge, to any person
+# obtaining a copy of this file, to deal in the File without
+# restriction, including without limitation the rights to use,
+# copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the File, and to permit persons to whom the
+# File is furnished to do so, subject to the following condition:
+#
+# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
+# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
+# THE USE OR OTHER DEALINGS IN THE FILE.
+
+########################################################################
+# The standard OMakeroot file.
+# You will not normally need to modify this file.
+# By default, your changes should be placed in the
+# OMakefile in this directory.
+#
+# If you decide to modify this file, note that it uses exactly
+# the same syntax as the OMakefile.
+#
+
+#
+# Include the standard installed configuration files.
+# Any of these can be deleted if you are not using them,
+# but you probably want to keep the Common file.
+#
+open build/C
+open build/OCaml
+open build/LaTeX
+
+#
+# The command-line variables are defined *after* the
+# standard configuration has been loaded.
+#
+DefineCommandVars()
+
+#
+# Include the OMakefile in this directory.
+#
+.SUBDIRS: .

examples/module_new.ml

+open Opycaml.Api
+
+let _ =
+  Base.initialize ();
+  let mdl = Module.new_ "MyModule" in
+  let mdldic = Import.getModuleDict () in
+  Dict.setItemString mdldic "MyModule" mdl;
+  let dic = Module.getDict mdl in
+  Dict.setItemString dic "answer" (Int.fromLong 42);
+  ignore (Base.main []);
+  Base.finalize ()
+;;
+
+
+  
+(* open Opycaml.Api is recommended. *)
+open Opycaml.Api
+
+let _ =
+  Base.initialize ();
+
+  let string = Import.importModule "string" in (* from string import * *)
+  let dict = Module.getDict string in
+  let lowercase = Dict.getItemString dict "lowercase" in
+  let capitalize = Dict.getItemString dict "capitalize" in
+
+  let res = Object.callObject (Callable.coerce capitalize) [lowercase] in
+
+  (* String class is not accessible by String but Py.String, in order
+     to avoid the name space collision with String in OCaml standard
+     library. *)
+  prerr_endline (Py.String.asString (Py.String.coerce res));
+
+  Base.finalize ()
+;;

examples/testoo.ml

+(* open Opycaml.Api is recommended. *)
+open Opycaml.OOApi
+
+let _ =
+  Base.initialize ();
+
+  let string = Import.importModule "string" in (* from string import * *)
+  let dict = string#getDict in
+  let lowercase = dict#getItemString "lowercase" in
+  let capitalize = dict#getItemString "capitalize" in
+
+  let res = Object.callObject (Callable.coerce capitalize) [lowercase] in
+
+  (* String class is not accessible by String but OPy.String, in order
+     to avoid the name space collision with String in OCaml standard
+     library. *)
+  prerr_endline (OPy.String.coerce res)#asString;
+
+  Base.finalize ()
+;;
     s/\[stolen\]\s*([A-Za-z0-9_]+)/$1_incr/g;
     s/\[internal\]//g;
     s/\[wrap\] ([A-Za-z0-9_]+)/$1_wrap/g; # in ML side, _wrap must be removed (module.pl)
+    s/\[mlname[^\]]*\]//g;
     if( /^[^\/]/ ){
         s/value/value_/g;
     }

js_of_ocaml/OMakefile

 OCAMLPPFLAGS += -syntax camlp4o -package js_of_ocaml.syntax
 OCAMLFLAGS += -annot
 
-.DEFAULT: $(OCamlProgram test, py_of_ocaml test)
+.DEFAULT: $(OCamlProgram test, py_of_ocaml opy_of_ocaml test)
+.DEFAULT: $(OCamlProgram testoo, py_of_ocaml opy_of_ocaml testoo)
 
 .PHONY: clean
 clean:

js_of_ocaml/opy_of_ocaml.ml

+open Opycaml.OOApi
+
+module OT = Opycaml.Type
+
+module Js : sig
+  type 'a t
+  type 'a gen_prop
+  type 'a readonly_prop = < get : 'a> gen_prop
+  type 'a meth
+  val dict : #OPy.o_Dict -> 'a t
+  module Unsafe : sig
+    val get : 'a t -> string -> 'b
+    val meth_call : 'a t -> string -> #OPy.o_Object array -> 'b
+    val inject : #OPy.o_Object -> OPy.o_Object
+  end
+end = struct
+  type 'a t = OPy.o_Dict
+  type 'a gen_prop
+  let dict = Obj.magic
+  module Unsafe = struct
+    let get (o : 'a t) name = Obj.magic (o#getItemString name)
+    let meth_call (o : OPy.o_Dict) name args = 
+      Obj.magic (Object.callObject (Callable.coerce (o#getItemString name)) (Array.to_list args ))
+    let inject = Obj.magic
+  end
+
+  type 'a readonly_prop = < get : 'a> gen_prop
+  type 'a meth
+end

js_of_ocaml/testoo.ml

+(* open Opycaml.Api is recommended. *)
+open Opycaml.OOApi
+open Opy_of_ocaml
+
+class type module_string = object
+  method lowercase  : OPy.o_String Js.readonly_prop
+  method capitalize : #OPy.o_String -> OPy.o_String Js.meth
+end
+
+let import_module_dict name = Js.dict (Import.importModule name)#getDict
+
+let _ =
+  Base.initialize ();
+
+  let module_string : module_string Js.t = import_module_dict "string" in (* from string import * *)
+  let lowercase = module_string##lowercase in
+  let res = module_string##capitalize( lowercase ) in
+
+  (* String class is not accessible by String but OPy.String, in order
+     to avoid the name space collision with String in OCaml standard
+     library. *)
+  prerr_endline res#asString;
+
+  Base.finalize ()
+;;
 #!/usr/bin/perl
 
+get_class_deps();
 get_comments();
 filter();
 
+%deps;
+
+# obtain class dependency from type.ml
+sub get_class_deps {
+    open(IN, "type.ml");
+    while(<IN>){
+	if( /type\s+(_[A-Z][a-z0-9]+)\s*=\s*\[([^\]]+)\]/ ){
+	    my $cls = $1;
+	    my $deps = $2;
+	    $cls =~ s/^_//;
+	    $deps =~ s/`_[A-Z][a-z]+//g;
+	    $deps =~ s/\(\*.*\*\)//g;
+	    $deps =~ s/_([A-Z])/$1/g;
+	    my @deps = split(/\s|\|/, $deps);
+	    $deps{$cls} = \@deps;
+	    printf STDERR "$cls: %s\n", join(' ', @{$deps{$cls}});
+	}
+    }
+    close(IN);
+}
+
+
 sub get_comments {
     for $i (@ARGV){
 	open(IN, "$i");
 		if( /\[internal\]/ ){
 		    $internal{$func_name} = 1;
 		}
+		if( /\[mlname ([^\]]+)\]/ ){
+		    $mlname{$func_name} = $1;
+		}
 		while(<IN>){
 		    if( /^\/\/\s*/ ){
 			$_ = $';
     }
 }
 
+%printed_module;
+
+sub print_module {
+    my $k = $_[0];
+
+    if( $printed_module{$k} ){ return; }
+    
+    for my $kk (@{$deps{$k}}) {
+	print_module($kk);
+    }
+
+    print STDERR "printing $k\n";
+    $printed_module{$k} = 1;
+
+    print "module $k = struct\n";
+    print $mod{$k};
+    if( $mod{$k} =~ /external check +: \[>_Object\] t -> bool/ ){
+        print 
+"  (** coercion to [_$k t]. Raises Coercion when impossible *)
+  let coerce : [>_Object] t -> _$k t = fun t ->
+    if check t then unsafe_coerce t else raise Coercion
+  ;;
+
+  (** coercion to [_$k t]. Return None when impossible *)
+  let coerce_opt : [>_Object] t -> _$k t option = fun t ->
+    if check t then Some (unsafe_coerce t) else None
+  ;;
+";
+    }
+    print "end\n\n";
+}
+
 sub filter {
     open(IN, "auto.ml");
     while(<IN>){
 	    $fname =~ s/py/Py/;
 	    $comment = $comment{$fname};
             $comment =~ s/\n/\n      /g;
+            # P4 parses << and >> in comments specially!
+            $comment =~ s/<</LessLess/g;
+            $comment =~ s/>>/GreaterGreater/g;
             $internal = $internal{$fname};
 
             # $f =~ s/GET_SIZE/get_size/;
       	        $f = lcfirst($f);
             }
     	    $f =~ s/^(type|and|or|new)$/$1_/;
+	    if( $mlname{$fname} ){ $f = $mlname{$fname}; }
             if( $internal ){ $f = "_internal_$f"; }
             $f =~ s/_wrap$//; # [wrap] cleanup
 
 
     print "open Type\n\n";
     for $k (keys %mod){
-        print "module $k = struct\n";
-        print $mod{$k};
-	if( $mod{$k} =~ /external check +: \[>_Object\] t -> bool/ ){
-	    print 
-"  (** coercion to [_$k t]. Raises Coercion when impossible *)
-  let coerce : [>_Object] t -> _$k t = fun t ->
-    if check t then unsafe_coerce t else raise Coercion
-  ;;
-
-  (** coercion to [_$k t]. Return None when impossible *)
-  let coerce_opt : [>_Object] t -> _$k t option = fun t ->
-    if check t then Some (unsafe_coerce t) else None
-  ;;
-";
-	}
-        print "end\n\n";
+	print_module($k);
     }
+    # a dummy module to indicate the end of the file
+    print "module Unicode = struct end\n";
+    print "module List = struct end\n";
+    print "module Slice = struct end\n";
+    print "module Float = struct end\n";
+    print "module Long = struct end\n";
 }
 
 PyIntObject* PyNumber_ToBase(PyNumberObject *n, int base);
 // Returns the integer n converted to base as a string with a base marker of '0b', '0o', or '0x' if applicable. When base is not 2, 8, 10, or 16, the format is 'x#num' where x is the base. If n is not an int object, it is converted with PyNumber_Index() first.
 
-size_or_fail PyNumber_AsSsize_t(PyNumberObject *o, PyObject *exc);
+size_or_fail PyNumber_AsSsize_t(PyNumberObject *o, PyObject *exc); [mlname asSsize_t_exn]
 // Returns o converted to a Py_ssize_t value if o can be interpreted as an integer. If o can be converted to a Python int or long but the attempt to convert to a Py_ssize_t value would raise an OverflowError, then the exc argument is the type of exception that will be raised (usually IndexError or OverflowError). If exc is NULL, then the exception is cleared and the value is clipped to PY_SSIZE_T_MIN for a negative integer or PY_SSIZE_T_MAX for a positive integer.
 
 boolean PyIndex_Check(PyObject *o); // or bool_or_fail ?
+.PHONY: all install clean
+
+USE_OCAMLFIND = true
+
+OCAMLPACKS[] =
+	camlp4
+
+OCAMLINCLUDES +=
+
+NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
+BYTE_ENABLED = true
+
+OCAMLCFLAGS   += -annot -w Ae-26
+OCAMLOPTFLAGS   += -annot -w Ae-26
+
+OCAMLPACKAGEFLAGS= 
+
+FILES[] =
+	oowrap
+
+LIB = oowrap
+
+.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
+
+clean:
+	rm $(filter-proper-targets $(ls R, .))
+
+OCAMLDEPFLAGS=-pp camlp4of
+OCAMLPPFLAGS=-pp camlp4of
+module rec M_Object : sig
+  class type s_Object = object
+    method int : int
+    method getIter : M_Iter.s_Iter
+  end
+end = struct
+  class type s_Object = object
+    method int : int
+    method getIter : M_Iter.s_Iter
+  end
+end
+
+and M_Iter : sig
+  class type s_Iter = object
+    inherit M_Object.s_Object
+    method float : float
+    method toObject : M_Object.s_Object
+  end
+end = struct
+  class type s_Iter = object
+    inherit M_Object.s_Object
+    method float : float
+    method toObject : M_Object.s_Object
+  end
+end
+
+open M_Object
+open M_Iter
+
+type t = int
+
+let new_o_Object = ref (fun _ -> assert false)
+let new_o_Iter = ref (fun _ -> assert false)
+
+class o_Object (t : t) : s_Object = object
+  method int = t
+  method getIter = !new_o_Iter t
+end
+
+let _ = new_o_Object := new o_Object
+
+class o_Iter (t : t) : s_Iter = object
+  inherit o_Object t
+  method float = float t
+  method toObject = !new_o_Object t
+end
+
+let _ = new_o_Iter := new o_Iter
+
+let _ = 
+  let o = new o_Object 1 in
+  assert (o#getIter#float = 1.0);
+  assert (o#getIter#toObject#getIter#toObject#int = 1)
+
+module Id = struct
+  let name = "oowrap"
+  let version = "1.0"
+end
+
+open Camlp4
+open PreCast
+
+(* See P4 filter tutorial at
+   http://ambassadortothecomputers.blogspot.com/2010/03/reading-camlp4-part-5-filters.html
+   http://brion.inria.fr/gallium/index.php/Camlp4MapGenerator
+*)
+
+module Topo_fold(G : sig
+  type t
+  type node (* comparison by (=) *)
+  val edges : t -> node -> node list
+  val nodes : t -> node list
+end) : sig
+
+  val topo_fold : ('a -> G.node -> 'a) -> 'a -> G.t -> 'a
+  (** simple topo sort, from leaves *)
+
+end = struct 
+
+  (* simple topo sort, from leaves *)
+  let topo_fold f init graph =
+    let rec visit ((visited, _) as vst) s =
+      if List.mem s visited then vst
+      else
+        let edges = G.edges graph s in
+        let visited, st = visits vst edges in
+        let st' = f st s in
+        (s::visited, st')
+    and visits vst ss = List.fold_left (fun vst p -> visit vst p) vst ss
+    in
+    snd (visits ([], init) (G.nodes graph))
+
+end
+
+module Make (AstFilters : Sig.AstFilters) = struct
+  open AstFilters
+  open Ast
+
+  (* Actually the AST is the same type, but the fact is not known to the type system.... *)
+  let print_str_item (sitem : str_item) = Register.CurrentPrinter.print_implem (Obj.magic sitem)
+
+  let _loc = Loc.ghost
+
+  let rec iter_sig_item ~f = function
+    | SgNil _ -> ()
+    | SgSem (_, sig_item1, sig_item2) -> iter_sig_item ~f sig_item1; iter_sig_item ~f sig_item2
+    | sig_item -> f <:sig_item< $sig_item$ >>
+
+  let rec fold_sig_item ~f ~init = function
+    | SgNil _ -> init
+    | SgSem (_, sig_item1, sig_item2) ->
+        let st = fold_sig_item ~f ~init sig_item1 in
+        fold_sig_item ~f ~init:st sig_item2
+    | sig_item -> f init <:sig_item< $sig_item$ >>
+
+  let rec get_polyvariants = function
+    | <:ctyp< $t1$ | $t2$ >> -> get_polyvariants t1 @ get_polyvariants t2
+    | <:ctyp< `$v$ >> -> [v]
+    | _ -> []
+
+  (* CR jfuruse: depend *)
+  let type_path_normalize = function
+    | <:ident< Type.$lid:name$ >> -> <:ident< $lid:name$ >>
+    | id-> id
+
+  (* Get class type encoding *)
+  let class_type =
+    let extract k varpath typath =
+      (* CR jfuruse: depend *)
+      let normalize_path p = match type_path_normalize p with
+        | <:ident< $lid:name$ >> -> Some name
+        | _ -> None
+      in
+      match normalize_path varpath, normalize_path typath with
+      | Some varpath, Some "t" -> Some (k, varpath)
+      | _ -> None
+    in
+    function
+    | <:ctyp< [> $id:varpath$ ] $id:typath$ >> -> extract `Bigger varpath typath
+    | <:ctyp< $id:varpath$ $id:typath$ >> -> extract `Equal varpath typath
+    | _ -> None
+
+  (* test *)
+  let _ =
+    assert (class_type <:ctyp< [> _Object ] t >> = Some (`Bigger, "_Object"));
+    assert (class_type <:ctyp< _Object Type.t >> = Some (`Equal, "_Object"))
+    assert (class_type <:ctyp< Type._Object Type.t >> = Some (`Equal, "_Object"))
+  ;;
+
+  module DepGraph = struct
+    module G = struct
+      type node = string
+      type t = (node, (node list * node list)) Hashtbl.t (* parents, and ancestors *)
+      let edges g n = fst (Hashtbl.find g n)
+      let nodes g = Hashtbl.fold (fun k _ st -> k :: st) g []
+    end
+    include G
+    include Topo_fold(G)
+  end
+
+  (* Obtain class dependencies encoded as poly-variant type definitions in the top sig *)
+  let get_class_dep_graph sig_item =
+    let ancestors =
+      let tbl = Hashtbl.create 107 in
+      iter_sig_item sig_item ~f:(function
+        | <:sig_item< type $lid:name$ = [ $tyors$ ] >> ->
+              prerr_endline ("found class dependency " ^ name);
+              let variants = get_polyvariants tyors in
+              (* remove self to create ancestors *)
+              let ancestors = List.filter (fun x -> x <> name) variants in
+              Hashtbl.add tbl name ancestors
+        | _ -> ());
+      tbl
+    in
+    let is_ancestor_of a k = List.mem a (try Hashtbl.find ancestors k with Not_found -> assert false) in
+
+    (* create direct parent relationship from [ancestors] *)
+    let tbl : DepGraph.t = Hashtbl.create 107 in
+    Hashtbl.iter (fun k ancs ->
+      (* direct parents are ancestors which are not ancestors of other ancestors *)
+      let parents = List.filter (fun anc ->
+        List.for_all (fun anc' -> not (is_ancestor_of anc anc')) ancs)
+        ancs
+      in
+      Format.eprintf "class dependency %s : %s@." k (String.concat " " parents);
+      Hashtbl.add tbl k (parents, ancs)
+    ) ancestors;
+    tbl
+
+  (* CR jfuruse: depend *)      
+  let check_rev_path classes rev_path =
+    let path = List.rev rev_path in
+    match path with
+    | [ "Py"; s ] when List.mem ("_" ^ s) classes -> true ,s
+    | _ -> false, "NOPE!"
+
+  let rec extract_vals classes sig_item =
+    let vals = ref [] in
+    let rec visit rev_path sig_item =
+      let register, mname = check_rev_path classes rev_path in
+      iter_sig_item sig_item ~f:(function
+        | <:sig_item< external $name$ : $typ$ = $_$ >> when register ->
+            Format.eprintf "%s : val %s (external)@." mname name;
+            vals := (mname, name, typ) :: !vals
+        | <:sig_item< val $name$ : $typ$ >> when register ->
+            Format.eprintf "%s : val %s@." (String.concat "." (List.rev rev_path)) name;
+            vals := (mname, name, typ) :: !vals
+        | <:sig_item< module $name$ : $ MtSig(_, sig_item) $ >> ->
+            let rev_path = name :: rev_path in
+            visit rev_path sig_item
+        | _ -> ())
+    in
+    visit [] sig_item;
+
+    let modules = Hashtbl.create 107 in
+    List.iter (fun cls ->
+      let cls = String.sub cls 1 (String.length cls - 1) in (* remove the prefix '_' *)
+      Hashtbl.replace modules cls []) classes;
+    let hashtbl_add_in_list tbl k v =
+      let vs = try Hashtbl.find tbl k with Not_found -> [] in
+      Hashtbl.replace tbl k (v::vs)
+    in
+    List.iter (fun (mname, name, typ) ->
+      hashtbl_add_in_list modules mname (name, typ)) !vals;
+    modules
+
+  (* Explicitly annotate tvars with open polymorphic types *)
+  let annotate_tvars ctyp =
+    let new_tvar =
+      let cntr = ref 0 in
+      fun () ->
+        incr cntr;
+        TyQuo(_loc, Printf.sprintf "x%d" !cntr) (* No ' required! *)
+    in
+    let rec map with_as ctyp =
+      match ctyp with
+      | TyNil _ -> ctyp
+      | TyAny _ -> assert false
+      | TyAli (loc, ct1, ct2) -> TyAli (loc, map true ct1, ct2)
+      | TyApp (loc, ct1, ct2) -> TyApp (loc, map false ct1, map false ct2)
+      | TyArr (loc, ct1, ct2) -> TyArr (loc, map false ct1, map false ct2)
+      | TyCls (_loc, _ident) -> assert false
+      | TyLab (loc, lab, ct) -> TyLab (loc, lab, map false ct)
+      | TyId _ -> ctyp
+      | TyMan _ -> assert false
+      | TyDcl _ -> assert false
+      | TyObj (loc, ctyp, RvRowVar) when not with_as ->
+          TyAli (_loc, TyObj (loc, map false ctyp, RvRowVar), new_tvar ())
+      | TyObj (loc, ctyp, rvf) -> TyObj (loc, map false ctyp, rvf)
+      | TyOlb (loc, lab, ct) -> TyOlb (loc, lab, map false ct)
+      | TyPol (loc, ct1, ct2) -> TyPol (loc, ct1, map false ct2)
+      | TyQuo _ -> ctyp
+      | TyQuP _ -> ctyp
+      | TyQuM _ -> ctyp
+      | TyVrn _ -> ctyp
+      | TyRec _ -> assert false
+      | TyCol (loc, l, ct) -> TyCol (loc, l, map false ct)
+      | TySem (loc, ct1, ct2) -> TySem (loc, map false ct1, map false ct2)
+      | TyCom (loc, ct1, ct2) -> TyCom (loc, map false ct1, map false ct2)
+      | TySum _ -> assert false
+      | TyOf _ -> assert false
+      | TyAnd _ -> assert false
+      | TyOr (loc, ct1, ct2) -> TyOr (loc, map false ct1, map false ct2)
+      | TyPrv _ -> assert false
+      | TyMut _ -> assert false
+      | TyTup (loc, ctyp) -> TyTup (loc, map false ctyp)
+      | TySta (loc, ct1, ct2) -> TySta (loc, map false ct1, map false ct2)
+      | TyVrnEq (loc, ctyp) -> TyVrnEq (loc, map false ctyp)
+      | TyVrnSup (loc, ctyp) when not with_as ->
+          TyAli (_loc, TyVrnSup (loc, map false ctyp), new_tvar ())
+      | TyVrnSup (loc, ctyp) -> TyVrnSup (loc, map false ctyp)
+      | TyVrnInf (loc, ctyp) when not with_as ->
+          TyAli (_loc, TyVrnInf (loc, map false ctyp), new_tvar ())
+      | TyVrnInf (loc, ctyp) -> TyVrnInf (loc, map false ctyp)
+      | TyVrnInfSup (loc, ct1, ct2) when not with_as ->
+          TyAli (_loc, TyVrnInfSup (loc, map false ct1, map false ct2), new_tvar ())
+      | TyVrnInfSup (loc, ct1, ct2) -> TyVrnInfSup (loc, map false ct1, map false ct2)
+
+      | TyAmp (loc, ct1, ct2) -> TyAmp (loc, map false ct1, map false ct2)
+      | TyOfAmp (loc, ct1, ct2) -> TyOfAmp (loc, map false ct1, map false ct2)
+      | TyPkg _ -> ctyp
+      | TyAnt _ -> assert false
+    in
+    map false ctyp
+
+  (* roughly list up free tvars *)
+  let free_tvars ctyp =
+    let nuv xs =
+      let rec nuv uniq = function
+        | [] -> uniq
+        | x::xs ->
+            if List.mem x uniq then nuv uniq xs
+            else nuv (x::uniq) xs
+      in
+      nuv [] xs
+    in
+    let rec f = function
+      | TyNil _
+      | TyId _
+      | TyVrn _
+      | TyPkg _ ->
+          []
+      | TyAny _ -> assert false
+      | TyAli (_, ct1, ct2)
+      | TyApp (_, ct1, ct2)
+      | TyArr (_, ct1, ct2)
+      | TySem (_, ct1, ct2)
+      | TyCom (_, ct1, ct2)
+      | TyOr (_, ct1, ct2)
+      | TySta (_, ct1, ct2)
+      | TyVrnInfSup (_, ct1, ct2)
+      | TyAmp (_, ct1, ct2)
+          -> f ct1 @ f ct2
+      | TyCls _ -> assert false
+      | TyLab (_, _, ct)
+      | TyObj (_, ct, _)
+      | TyOlb (_, _, ct)
+      | TyCol (_, _, ct)
+      | TyOf (_, _, ct)
+      | TyPrv (_, ct)
+      | TyMut (_, ct)
+      | TyTup (_, ct)
+      | TyVrnEq (_, ct)
+      | TyVrnSup (_, ct)
+      | TyVrnInf (_, ct)
+      | TyOfAmp (_, _, ct)
+        -> f ct
+      | TyMan _ -> assert false
+      | TyDcl _ -> assert false
+      | TySum _ -> assert false
+      | TyPol (_, ct1, ct2) ->
+          let abs_tvars = f ct1 in
+          List.filter (fun tv -> not (List.mem tv abs_tvars)) (f ct2)
+      | TyQuo (_, name)
+      | TyQuP (_, name)
+      | TyQuM (_, name) -> [name]
+      | TyRec _ -> assert false
+      | TyAnd _ -> assert false
+      | TyAnt _ -> assert false
+    in
+    nuv (f ctyp)
+
+  let quantify_free_tvars cty =
+    let acty = annotate_tvars cty in
+    let fvars = free_tvars acty in
+    if fvars = [] then acty
+    else
+      let rec qapp = function
+        | [] -> assert false
+        | [qv] -> TyQuo(_loc, qv)
+        | qv::qvs -> TyApp(_loc, TyQuo(_loc, qv), qapp qvs) (* strange but it is as an app *)
+      in
+      TyPol (_loc, qapp fvars, acty)
+
+  module A = struct (* Dirty part *)
+
+    let class_name s = "o" ^ s
+    let m_class_ident s : ident = <:ident< M. $lid: "o" ^ s $ >>
+
+    let mk_id pos = Printf.sprintf "v%d" pos
+
+    let mk_tyvar pos = TyQuo(_loc, Printf.sprintf "a%d" pos) (* No ' required! *)
+
+    let extract_class_from_type = function
+      | <:ctyp< [ > $id:clsname$ ] $id:t$ >> -> Some (`Bigger, clsname, t, None)
+      | <:ctyp< [ > $id:clsname$ ] $id:t$ $id:container$ >> -> Some (`Bigger, clsname, t, Some container)
+      | <:ctyp< $id:clsname$ $id:t$ >> -> Some (`Equal, clsname, t, None)
+      | <:ctyp< $id:clsname$ $id:t$ $id:container$ >> -> Some (`Equal, clsname, t, Some container)
+      | _ -> None
+
+    let rec mk_mapper = function
+      | <:ident< $lid:id$ >> -> <:ident< $lid: id ^ "_map"$ >>
+      | <:ident< $id1$.$id2$ >> -> <:ident< $id1$.$ mk_mapper id2 $ >>
+      | _ -> assert false
+
+    (* [> _Cls ] t -> ...   =>    < _Cls : _Cls t; .. > -> ... *)
+    let wrap_in v ty0 =
+
+      (* escape label *)
+      let ty, recover_label =
+        match ty0 with
+        | TyLab(loc, name, ty) -> ty, fun ty -> TyLab(loc, name, ty)
+        | TyOlb(loc, name, ty) -> 
+            <:ctyp< $ty$ option >>, 
+            (fun ty -> 
+              match ty with
+              | <:ctyp< $ty$ option >> -> TyOlb(loc, name, ty)
+              | _ -> assert false)
+        | _ -> ty0, fun ty -> ty
+      in
+
+      let extract_arg_type = function
+        | <:ctyp< [ > $id:clsname$ ] $id:t$ >> -> Some (clsname, t, None)
+        | <:ctyp< [ > $id:clsname$ ] $id:t$ $id:container$ >> -> Some (clsname, t, Some container)
+        | _ -> None
+      in
+
+      let normalize_arg_type ctyp = 
+        match extract_class_from_type ctyp with
+        | None | Some (`Equal, _, _, _) -> None
+        | Some (`Bigger, clsname, t, container) ->
+            let clsname = type_path_normalize clsname in
+            let t = type_path_normalize t in
+            match clsname, t with
+            | <:ident< $lid:clsname$ >>, <:ident< t >> -> Some (clsname, container)
+            | _ -> None
+      in
+
+      match normalize_arg_type ty with
+      | None -> v, ty0
+      | Some (clsname, None) ->
+          let oty = recover_label <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
+          <:expr< $v$ # $clsname$ >>, oty
+      | Some (clsname, Some cont) ->
+          let oty = recover_label <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > $id:cont$ >> in
+          <:expr< $id:mk_mapper cont$ $v$ (fun x -> x# $clsname$) >>, oty
+    ;;
+
+    (* ... -> _Cls t   =>   ... -> _Cls *)
+    let wrap_out ty =
+      let normalize_arg_type ctyp =
+        match extract_class_from_type ctyp with
+        | None | Some (`Bigger, _, _, _) -> None
+        | Some (`Equal, clsname, t, container) ->
+            let clsname = type_path_normalize clsname in
+            let t = type_path_normalize t in
+            match clsname, t with
+            | <:ident< $lid:clsname$ >>, <:ident< t >> -> Some (clsname, container)
+            | _ -> None
+      in
+      match normalize_arg_type ty with
+      | None -> (fun e -> e), ty
+      | Some (clsname, None) ->
+          (fun e -> <:expr< ! $lid: "new_" ^ class_name clsname$ $e$ >>),
+          <:ctyp< $id: m_class_ident clsname$ >>
+
+      | Some (clsname, Some cont) ->
+          (fun e -> <:expr< $id: mk_mapper cont$ $e$ (! $lid: "new_" ^ class_name clsname$) >>),
+          <:ctyp< $id: m_class_ident clsname $ $id: cont$ >>
+    ;;
+
+    let wrap_oo base ty =
+
+      let rec args pos = function
+        | <:ctyp< $argty$ -> $ty$ >> ->
+
+            (* CR jfuruse: Should move to wrap_in *)
+            let add_pat_label, add_exp_label =
+              match argty with
+              | TyLab (_, lab, _argty) ->
+                  (fun p -> PaLab (_loc, lab, p)),
+                  (fun e -> ExLab (_loc, lab, e))
+              | TyOlb (_, lab, _argty) ->
+                  (fun p -> PaOlb (_loc, lab, p)),
+                  (fun e -> ExOlb (_loc, lab, e))
+              | _ -> let id x = x in id, id
+            in
+
+            let mty, absts, args, mk_return = args (pos+1) ty in
+
+            let v = <:expr<$lid:mk_id pos$>> in
+
+            let pat = add_pat_label <:patt< $lid:mk_id pos$ >> in
+            let e, oty = wrap_in v argty in
+            let e = add_exp_label e in
+
+            let absts = pat :: absts in
+            let args = e :: args in
+
+            let mty = <:ctyp< $oty$ -> $mty$ >> in
+
+            mty, absts, args, mk_return
+
+        | mty ->
+            let mk_return, mty = wrap_out mty in
+            mty, [], [], mk_return
+      in
+      let mty, absts, args, mk_return = args 0 ty in (* X *)
+      let rec mk_app b = function
+        | [] -> b
+        | e::es -> mk_app <:expr< $b$ $e$ >> es
+      in
+      let rec mk_abst b = function
+        | [] -> b
+        | v::vs -> <:expr< fun $v$ -> $mk_abst b vs$ >>
+      in
+      quantify_free_tvars mty, mk_abst (mk_return (mk_app base args)) absts
+
+  end
+  (*  open A *)
+
+  let build class_dep_graph modules =
+    Hashtbl.fold (fun modname name_typ_list (clses, st) ->
+      (* common names *)
+      let tyname = "_" ^ modname in
+      let clsname = "o" ^ tyname in
+
+      (* Create non-methods and methods *)
+      let sitems, methods =
+        List.fold_left (fun (st, methods) (name, typ) ->
+          match typ with
+          | <:ctyp<  $arg$ -> $typ'$  >> ->
+              begin match class_type arg with
+              | Some (`Bigger, tyname') when tyname' = tyname -> (* Make it a method! *)
+                  let polytype, exp = A.wrap_oo <:expr< Py.$uid:modname$.$lid:name$ t >> typ' in
+                  st, <:class_str_item< method $name$ : $polytype$ = $exp$ >> :: methods
+              | _ ->
+                  let polytype, exp = A.wrap_oo <:expr< Py.$uid:modname$.$lid:name$ >> typ in
+                  <:str_item<  let $lid:name$ : $polytype$ = $exp$ ;; $st$ >>, methods
+              end
+          | _ -> st, methods
+        ) (<:str_item<>>, [])  name_typ_list
+      in
+
+      let inherits =
+        let inherits = try fst (Hashtbl.find class_dep_graph tyname) with _ -> [] in
+        List.fold_left (fun st x ->
+          let ox = "o" ^ x in
+          CrSem(_loc, <:class_str_item< inherit $lid:ox$ t >>, st))
+          <:class_str_item<>>
+          inherits
+      in
+
+      let unwrap = <:class_str_item< method $tyname$ = (t :> Api.$lid:tyname$ Api.t) >> in
+
+      let method_sigs =
+        let method_sigs = List.map (function
+          | <:class_str_item< method $name$ : $polytype$ = $_$ >> ->
+            <:class_sig_item< method $name$ : $polytype$ >>
+          | _ -> assert false) methods
+        in
+        let init =
+          (* To avoid OCaml mututal recursive module + inheritance bug,
+             it includes all the ancestors.  *)
+          let inherits = try snd (Hashtbl.find class_dep_graph tyname) with _ -> [] in
+          List.fold_left (fun st x ->
+            let ox = "o" ^ x in
+            CgSem(_loc, <:class_sig_item< inherit M.$lid:ox$ >>, st))
+          <:class_sig_item< method $tyname$ : Api.$lid:tyname$ Api.t >> inherits
+        in
+        List.fold_left (fun st x -> CgSem(_loc, st, x)) init method_sigs
+      in
+
+      let methods = List.fold_left (fun st x -> CrSem(_loc, st, x)) <:class_str_item<>> methods in
+      let sitem =
+        <:str_item<
+           class $lid:clsname$ t : M.$lid:clsname$ = object
+               $inherits$
+               $unwrap$
+               $methods$
+           end
+           let _ = $lid: "new_" ^ clsname$ := new $lid:clsname$
+        >>
+      in
+
+      let cltype = CtEq(_loc,
+                        CtCon(_loc, ViNil, <:ident< $lid:clsname$ >>, <:ctyp<>>),
+                        <:class_type< object $method_sigs$ end >>)
+      in
+
+      (
+        (tyname, sitem, cltype) :: clses,
+
+        <:str_item<
+          $st$
+          module $modname$ = struct
+            open Open (* To avoid name space collisions with Python's Type module *)
+            $sitems$
+          end
+        >>
+      ) ) modules ([], <:str_item<>>)
+
+  let build class_dep_graph modules =
+    let clses, st = build class_dep_graph modules in
+
+    let news =
+      List.fold_left (fun st (tyname, _, _) ->
+        <:str_item<
+            $st$
+            let $lid: "new_o" ^ tyname$ : ( $lid:tyname$ t -> M.$lid: "o" ^ tyname$ ) ref = ref (fun _ -> assert false) >>) <:str_item<>> clses
+    in
+
+    (* create structure of classes in the order of dependency *)
+
+    let tbl = Hashtbl.create 107 in
+    List.iter (fun (tyname, sitem, cltype) -> Hashtbl.add tbl tyname (sitem, cltype)) clses;
+
+    let mutual_class_types =
+      let rec concat = function
+        | [] -> raise Not_found
+        | [x] -> x
+        | x::xs -> CtAnd(_loc, x, concat xs)
+      in
+      let cltype = concat (List.map (fun (_,_,cltype) -> cltype) clses) in
+      try
+        <:str_item< module rec M : sig class type $cltype$ end = M >>
+      with
+      | Not_found -> <:str_item< module rec M : sig end = M >>
+    in
+
+    let print_class st tyname =
+      let (i, _) = Hashtbl.find tbl tyname in
+      <:str_item< $st$ $i$ >>
+    in
+
+    let classes = DepGraph.topo_fold print_class <:str_item<>> class_dep_graph in 
+
+    <:str_item<
+      open Type;;
+      module Open = struct module Type = Type end (* To avoid name space collisions with Python's Type module *)
+      module Py = Api.Py;;
+      let option_map v f = match v with
+        | Some v -> Some (f v)
+        | None -> None
+      ;;
+      let list_map v f = List.map f v
+      ;;
+      $mutual_class_types$
+      $news$
+      $classes$
+      $st$
+    >>
+
+  let wrap_sig_item sig_item =
+    let class_dep_graph = get_class_dep_graph sig_item in
+    let classes = Hashtbl.fold (fun k _ st -> k::st) class_dep_graph [] in
+    let modules = extract_vals classes sig_item in
+    build class_dep_graph modules
+
+  let wrap = object
+    inherit Ast.map as super
+
+    method !sig_item sig_item =
+      let str_item = wrap_sig_item sig_item in
+      (* A hack to print out implementation, in an intf filter *)
+      print_str_item str_item;
+      <:sig_item< >>
+  end
+
+  let _ = AstFilters.register_sig_item_filter wrap#sig_item
+end
+
+let module M = Register.AstFilter(Id)(Make) in ()
+
+
+camlp4o oowrap.cmo -printer Camlp4OCamlPrinter ../api.auto.mli

pa/OMakefile

-.PHONY: all install clean
-
-USE_OCAMLFIND = true
-
-OCAMLPACKS[] =
-	camlp4
-
-OCAMLINCLUDES +=
-
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-OCAMLCFLAGS   += -annot -w Ae
-
-OCAMLPACKAGEFLAGS= 
-
-FILES[] =
-	pa_opycaml
-
-LIB = pa_opycaml
-
-.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-clean:
-	rm $(filter-proper-targets $(ls R, .))
-
-OCAMLDEPFLAGS=-pp camlp4of
-OCAMLPPFLAGS=-pp camlp4of
-
-# top_test: pa_bind_inline.cma
-# 	ocaml -I +camlp4 dynlink.cma camlp4o.cma pa_bind_inline.cma 
-# 
-# .PHONY: test
-# 
-# test: pa_bind_inline.cma
-# 	camlp4o -printer OCaml -I . pa_bind_inline.cma test_pa_bind_inline.ml  
-
-# It is local use
-
-# install: pa_bind_inline.cma pa_bind_inline.cmxa
-# 	ocamlfind remove bind_inline
-# 	ocamlfind install bind_inline META pa*.cmo pa*.cmx pa*.cmi pa*.cma pa*.cmxa

pa/pa_opycaml.ml

-module Id = struct
-  let name = "pa_opycaml"
-  let version = "1.0"
-end
-
-open Camlp4
-open PreCast
-
-(* See tutorial at 
-   http://ambassadortothecomputers.blogspot.com/2010/03/reading-camlp4-part-5-filters.html 
-   http://brion.inria.fr/gallium/index.php/Camlp4MapGenerator
-*)
-
-module Make (AstFilters : Sig.AstFilters) = struct
-  open AstFilters
-
-  let _ = 
-    let simplify = object
-      inherit Ast.map as super
-      method! str_item sitem =
-        let sitem = super#str_item sitem in
-        match sitem with
-        | Ast.StMod (mloc, modname, module_expr) ->
-(* does not work
-        | <:str_item@mloc< module $modname$ = $module_expr$ >> ->
-*)
-            begin match module_expr with
-            | Ast.MeStr (sloc, sitems) ->
-(* does not work
-            | <:module_expr@sloc< struct $sitem$ end >> ->
-*)
-                let rec iter_sitems f = function
-                  | Ast.StSem (_, sitem1, sitem2) -> iter_sitems f sitem1; iter_sitems f sitem2
-                  | i -> f i
-                in 
-(* does not work
-                let rec iter_sitems f = function
-                  | <:str_item< $sitem1$ $sitem2$ >> -> iter_sitems f sitem1; iter_sitems f sitem2
-                  | i -> f i
-                in 
-*)
-                let meths = ref [] in
-                iter_sitems (function
-                  | Ast.StExt (loc, name, <:ctyp< [ > $cls$ ] t -> $ty_rest$>>, _slist) -> 
-                      begin match cls with
-                      | <:ctyp<$lid:tname$>> when tname = "_" ^ modname -> meths := (name, loc, ty_rest) :: !meths
-                      | _ -> ()
-                      end
-                  | _ -> ()
-                ) sitems;
-                let create_meth name loc ty_rest = 
-                  let _loc = Ast.Loc.ghost in
-                  let var pos = Printf.sprintf "v%d" pos in
-                  let tv pos = Ast.TyQuo(_loc, Printf.sprintf "a%d" pos) in (* No ' required! *)
-                  let id = <:expr@loc< $lid:name$ >> in
-
-                  let rec args pos = function
-                    | <:ctyp< $argty$ -> $ty$ >> ->
-
-                        let qvars, mty, absts, args = args (pos+1) ty in
-
-                        let v = <:expr<$lid:var pos$>> in
-                        let pat = var pos in
-                        let e = 
-                          match argty with
-                          | <:ctyp< [ > $cls$ ] t >> -> 
-                              begin match cls with
-                              | <:ctyp< $lid:clsname$ >> -> <:expr< $v$#$clsname$ >>
-                              | _ -> v
-                              end
-                          | _ -> v
-                        in
-                        
-                        let absts = pat :: absts in
-                        let args = e :: args in
-
-                        let qvars, mty = 
-                          match argty with
-                          | <:ctyp< [ > $cls$ ] t >> -> 
-                              begin match cls with
-                              | <:ctyp< $lid:clsname$ >> ->  (* X *)
-                                  let tv = tv pos in
-                                  (* Strange, but < $ctyp$ : $ctyp$; ..> *)
-                                  let oty = <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
-                                  tv :: qvars, 
-                                  <:ctyp< $ Ast.TyAli(_loc, oty, tv) $ -> $mty$ >>
-                              | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
-                              end
-                          | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
-                        in
-                          
-
-                        qvars, mty, absts, args
-
-                    | mty -> [], mty, [], []
-                  in
-                  let qvars, mty, absts, args = args 0 ty_rest in (* X *)
-                  let q mty = function
-                    | [] -> mty
-                    | qvs ->
-                        let rec qapp = function
-                          | [] -> assert false
-                          | [qv] -> qv
-                          | qv::qvs -> Ast.TyApp(_loc, qv, qapp qvs) (* strange but it is as an app *)
-                        in
-                        Ast.TyPol (_loc, qapp qvs, mty)
-                  in
-                  let rec app b = function
-                    | [] -> b
-                    | e::es -> app <:expr< $b$ $e$ >> es
-                  in
-                  let rec abst b = function
-                    | [] -> b
-                    | v::vs -> <:expr< fun $lid:v$ -> $abst b vs$ >>
-                  in
-                  <:class_str_item@loc< method $name$ : $q mty qvars$ = $abst (app <:expr<$id$ t>> args) absts$ >> 
-                in
-
-                begin match !meths with
-                | [] -> sitem
-                | _ ->
-                    let meths = 
-                      let _loc = Ast.Loc.ghost in
-                      List.fold_left (fun st (name, loc, ty_rest) -> 
-                        <:class_str_item< $create_meth name loc ty_rest$ $st$ >>)
-                      <:class_str_item<>> !meths
-                    in
-                    let _loc = Ast.Loc.ghost in
-                    let tname = "_" ^ modname in
-                    let tnametyp = <:ctyp< $lid:tname$ >> in
-                    let sitems' = <:str_item< 
-                      $sitems$
-                      class o t = object
-                        $meths$
-                        method $tname$ = (t :> $tnametyp$  t )
-                      end >>
-                    in
-                    let meStr = <:module_expr@sloc< struct $sitems'$ end >> in
-                    <:str_item@mloc< module $modname$ = $meStr$ >>
-                end
-            | _ -> sitem
-            end
-        | sitem -> sitem
-    end
-    in AstFilters.register_str_item_filter simplify#str_item
-
-end
-
-let module M = Register.AstFilter(Id)(Make) in ()

pa/test.sh

-camlp4of ./pa_opycaml.cmo -impl ../autoapi.mlp 
-
 // Return value: New reference.
 // Return the result of repeating sequence object o count times, or NULL on failure. The operation is done in-place when o supports it. This is the equivalent of the Python expression o *= count.
 
-[new] PyObject* PySequence_GetItem(PySequenceObject *o, Py_ssize_t i);
+[new] PyObject* PySequence_GetItem(PySequenceObject *o, Py_ssize_t i); [mlname getItemPos]
 // Return value: New reference.
 // Return the ith element of o, or NULL on failure. This is the equivalent of the Python expression o[i].
 
 // Return value: New reference.
 // Return the slice of sequence object o between i1 and i2, or NULL on failure. This is the equivalent of the Python expression o[i1:i2].
 
-unit_or_fail PySequence_SetItem(PySequenceObject *o, Py_ssize_t i, [stolen] PyObject *v);
+unit_or_fail PySequence_SetItem(PySequenceObject *o, Py_ssize_t i, [stolen] PyObject *v); [mlname setItemPos]
 // Assign object v to the ith element of o. Returns -1 on failure. This is the equivalent of the Python statement o[i] = v. This function does not steal a reference to v.
 
-unit_or_fail PySequence_DelItem(PySequenceObject *o, Py_ssize_t i);
+unit_or_fail PySequence_DelItem(PySequenceObject *o, Py_ssize_t i); [mlname delItemPos]
 // Delete the ith element of object o. Returns -1 on failure. This is the equivalent of the Python statement del o[i].
 
 unit_or_fail PySequence_SetSlice(PySequenceObject *o, Py_ssize_t i1, Py_ssize_t i2, PySequenceObject *v);
 size_or_fail PyTuple_GET_SIZE(PyTupleObject *p);
 // Return the size of the tuple p, which must be non-NULL and point to a tuple; no error checking is performed.
 
-PyObject* PyTuple_GetItem(PyTupleObject *p, Py_ssize_t pos);
+PyObject* PyTuple_GetItem(PyTupleObject *p, Py_ssize_t pos); [mlname getItemPos]
 // Return value: Borrowed reference.
 // Return the object at position pos in the tuple pointed to by p. If pos is out of bounds, return NULL and sets an IndexError exception.
 
 // Return value: New reference.
 // Take a slice of the tuple pointed to by p from low to high and return it as a new tuple.
 
-unit_or_fail PyTuple_SetItem(PyTupleObject *p, Py_ssize_t pos, [stolen] PyObject *o);
+unit_or_fail PyTuple_SetItem(PyTupleObject *p, Py_ssize_t pos, [stolen] PyObject *o); [mlname setItemPos]
 // Insert a reference to object o at position pos of the tuple pointed to by p. Return 0 on success.
 // 
 // Note This function “steals” a reference to o.
 type _String = [_Sequence | `_String]
 type _Unicode = [_String (* ? *) | `_Unicode]
 type _Tuple = [_Sequence | `_Tuple]
-type _Mutable = [_Sequence | `Mutable]
+type _Mutable = [_Sequence | `_Mutable]
 type _List = [_Mutable | `_List]
 type _ByteArray = [_Mutable | `_ByteArray]
 (* _Set
 
 type _Closure = [_Object | `_Closure]
 
+type _Run = [_Object | `_Run]
+type _Eval = [_Object | `_Eval]
+type _DictProxy = [_Object | `_DictProxy]
+type _Err = [_Object | `_Err]
+type _Base = [_Object | `_Base]
+type _Import = [_Object | `_Import]
+
 (** the Python Object type. It is contravariant, since object with richer interface can be poorer *)
 type -'a t