1. camlspotter
  2. opycaml

Commits

camlspotter  committed eba6846

fix

  • Participants
  • Parent commits 4507fbf
  • Branches dev

Comments (0)

Files changed (5)

File OMakefile

View file
     ./module.pl *.idl.in > $@
 
 autoapioo.ml: autoapi.ml pa/pa_opycaml.cmo
-    camlp4of ./pa/pa_opycaml.cmo -impl autoapi.ml -printer Camlp4OCamlPrinter > $@
+    camlp4o ./pa/pa_opycaml.cmo -impl autoapi.ml -printer Camlp4AutoPrinter > $@
 
 auto_stubs.o: auto_stubs.c auto.h api_ml.h autoclasses.h
 

File module.pl

View file
 	    $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/;
     for $k (keys %mod){
 	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";
 }
 

File pa/OMakefile

View file
 NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
 BYTE_ENABLED = true
 
-OCAMLCFLAGS   += -annot -w Ae
+OCAMLCFLAGS   += -annot -w Ae-26
+OCAMLOPTFLAGS   += -annot -w Ae-26
 
 OCAMLPACKAGEFLAGS= 
 

File pa/pa_opycaml.ml

View file
     let _loc = Loc.ghost in
     List.fold_left (fun st sitem -> <:str_item< $st$ $sitem$ >>) <:str_item<>> sitems
 
+  (** Concatenate str items *)
+  let concat_class_exprs es =
+    let _loc = Loc.ghost in
+    StCls (_loc, 
+           List.fold_left (fun st e -> <:class_expr< $st$ and $e$ >>) <:class_expr<>> es)
+
+  let classes = ref []
+  let modules = ref []
+
   let _ =
-    let simplify = object
+    let wrap = object
 
       inherit Ast.map as super
 
-      method! str_item sitem =
-        let sitem = super#str_item sitem in
+      method! str_item sitem = 
+        iter_sitems (function
+          | StMod (mloc, modname, MeStr (sloc, sitems)) ->
+              (* does not work
+                 | <:str_item@mloc< module $modname$ = $module_expr$ >> ->
+                 | <:module_expr@sloc< struct $sitem$ end >> -> *)
 
-        match sitem with
-        | StMod (mloc, modname, MeStr (sloc, sitems)) ->
-            (* does not work
-               | <:str_item@mloc< module $modname$ = $module_expr$ >> ->
-               | <:module_expr@sloc< struct $sitem$ end >> -> *)
-
-            (* Obtain functions which can be methods or not *)
-            let meths, non_meths = fold_sitems (fun (meths, non_meths) si ->
-              match si with
-              | StExt (loc, name, ty, _slist) ->
-                  let non_meth = name, loc, ty in
-                  begin match ty with
-                  | <:ctyp< [ > $cls$ ] t -> $ty_rest$>> ->
+              (* Obtain functions which can be methods or not *)
+              let meths, non_meths = fold_sitems (fun (meths, non_meths) si ->
+                match si with
+                | StExt (loc, name, ty, _slist) ->
+                    let non_meth = name, loc, ty in
+                    begin match ty with
+                    | <:ctyp< [ > $cls$ ] t -> $ty_rest$>> ->
                       (* <:str_item< external $name$ : [ > $cls$ ] t -> $_$ = $_$>> ->     DOES NOT WORK... *)
-                      begin match cls with
-                      | <:ctyp<$lid:tname$>> when tname = "_" ^ modname ->
-                          (name, loc, ty_rest) :: meths, non_meths
-                      | _ -> meths, non_meth :: non_meths
-                      end
-                  | _ -> meths, non_meth :: non_meths
-                  end
-              | _ -> meths, non_meths (* ignored *))
-              ([], [])
-              sitems
-            in
+                        begin match cls with
+                        | <:ctyp<$lid:tname$>> when tname = "_" ^ modname ->
+                            (name, loc, ty_rest) :: meths, non_meths
+                        | _ -> meths, non_meth :: non_meths
+                        end
+                    | _ -> meths, non_meth :: non_meths
+                    end
+                | _ -> meths, non_meths (* ignored *))
+                ([], [])
+                sitems
+              in
 
             (* [> _Cls ] t ->    =>    _Cls -> *)
-            let arg v ty =
-              let _loc = Loc.ghost in
-              match ty with
-              | <:ctyp< [ > $ <:ctyp@tyloc< $lid:clsname$ >> $ ] t >> ->
-                  <:expr@_loc< $v$#$clsname$ >>, <:ctyp@tyloc< $lid:clsname$ >>
-              | _ -> v, ty
+              let arg v ty =
+                let _loc = Loc.ghost in
+                match ty with
+                | <:ctyp< [ > $ <:ctyp@tyloc< $lid:clsname$ >> $ ] t >> ->
+                    <:expr@_loc< $v$#$clsname$ >>, <:ctyp@tyloc< $lid: "o" ^ clsname$ >>
+                | _ -> v, ty
+              in
+
+              let return ty =
+                let _loc = Loc.ghost in
+                match ty with
+                | <:ctyp< $ <:ctyp@tyloc< Autoapi . $lid:clsname$ >> $ t >> ->
+                    (fun e -> <:expr@_loc< new $lid:"o" ^ clsname$ $e$ >>), <:ctyp@tyloc< $lid: "o" ^ clsname$ >>
+                | _ -> (fun e -> e), ty
+              in
+
+              let wrap_oo base ty =
+                let _loc = Loc.ghost in
+                let mk_id pos = Printf.sprintf "v%d" pos in
+                let mk_tyvar pos = TyQuo(_loc, Printf.sprintf "a%d" pos) in (* No ' required! *)
+
+                let rec args pos = function
+                  | <:ctyp< $argty$ -> $ty$ >> ->
+
+                      let qvars, mty, absts, args, mk_return = args (pos+1) ty in
+
+                      let v = <:expr<$lid:mk_id pos$>> in
+                      let pat = mk_id pos in
+                      let e, _ = arg v argty 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 = mk_tyvar pos in
+                              (* Strange, but < $ctyp$ : $ctyp$; ..> *)
+                                let oty = <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
+                                tv :: qvars,
+                                <:ctyp< $ TyAli(_loc, oty, tv) $ -> $mty$ >>
+                            | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                            end
+                        | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                      in
+                      qvars, mty, absts, args, mk_return
+
+                  | mty ->
+                      let mk_return, mty = return mty in
+                      [], mty, [], [], mk_return
+                in
+                let qvars, mty, absts, args, mk_return = args 0 ty in (* X *)
+                let q mty = function
+                  | [] -> mty
+                  | qvs ->
+                      let rec qapp = function
+                        | [] -> assert false
+                        | [qv] -> qv
+                        | qv::qvs -> TyApp(_loc, qv, qapp qvs) (* strange but it is as an app *)
+                      in
+                      TyPol (_loc, qapp qvs, mty)
+                in
+                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 $lid:v$ -> $mk_abst b vs$ >>
+                in
+                q mty qvars, mk_abst (mk_return (mk_app base args)) absts
+              in
+
+              let mk_non_method name loc ty =
+                let id = <:expr@loc< $lid:name$ >> in
+                let poly_type, expr = wrap_oo id ty in
+                <:str_item@loc<
+                  let $lid:name$ : $poly_type$ = $expr$
+                    >>
+                  in
+
+                  let mk_method name loc ty_rest =
+                    let id = <:expr@loc< Autoapi . $lid:modname$.$lid:name$ >> in
+                    let poly_type, expr = wrap_oo <:expr@loc<$id$ t>> ty_rest in
+                    <:class_str_item@loc<
+                     method $name$ : $poly_type$ = $expr$
+                     >>
+                  in
+
+                  let non_meths = concat_str_items 
+                    (List.map (fun (name, loc, ty) -> mk_non_method name loc ty) non_meths)
+                  in
+
+                  let meths =
+                    concat_class_str_items
+                      (List.map (fun (name, loc, ty_rest) -> mk_method name loc ty_rest) meths)
+                  in
+                  let _loc = Loc.ghost in
+                  let tname = "_" ^ modname in
+                  let tnametyp = <:ctyp< $lid:tname$ >> in
+                  let sitem_class = 
+                    <:str_item<
+                  class $lid: "o" ^ tname$ t = object
+                      $meths$
+                      method $tname$ = (t :> $tnametyp$  t )
+                  end >>
             in
-
-            let return ty =
-              let _loc = Loc.ghost in
-              match ty with
-              | <:ctyp< $ <:ctyp@tyloc< $lid:clsname$ >> $ t >> ->
-                  (fun e -> <:expr@_loc< new $lid:clsname$ $e$ >>), <:ctyp@tyloc< $lid:clsname$ >>
-              | _ -> (fun e -> e), ty
+            let class_expr = 
+              match 
+                fold_sitems (fun st -> function
+                  | StCls (_, cle) -> cle :: st
+                  | _ -> st
+                ) [] sitem_class
+              with
+              | [cle] -> cle
+              | _ -> assert false
             in
-
-            let wrap_oo base ty =
-              let _loc = Loc.ghost in
-              let mk_id pos = Printf.sprintf "v%d" pos in
-              let mk_tyvar pos = TyQuo(_loc, Printf.sprintf "a%d" pos) in (* No ' required! *)
-
-              let rec args pos = function
-                | <:ctyp< $argty$ -> $ty$ >> ->
-
-                    let qvars, mty, absts, args, mk_return = args (pos+1) ty in
-
-                    let v = <:expr<$lid:mk_id pos$>> in
-                    let pat = mk_id pos in
-                    let e, _ = arg v argty 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 = mk_tyvar pos in
-                                  (* Strange, but < $ctyp$ : $ctyp$; ..> *)
-                              let oty = <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
-                              tv :: qvars,
-                              <:ctyp< $ TyAli(_loc, oty, tv) $ -> $mty$ >>
-                          | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
-                          end
-                      | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
-                    in
-                    qvars, mty, absts, args, mk_return
-
-                | mty ->
-                    let mk_return, mty = return mty in
-                    [], mty, [], [], mk_return
-              in
-              let qvars, mty, absts, args, mk_return = args 0 ty in (* X *)
-              let q mty = function
-                | [] -> mty
-                | qvs ->
-                    let rec qapp = function
-                      | [] -> assert false
-                      | [qv] -> qv
-                      | qv::qvs -> TyApp(_loc, qv, qapp qvs) (* strange but it is as an app *)
-                    in
-                    TyPol (_loc, qapp qvs, mty)
-              in
-              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 $lid:v$ -> $mk_abst b vs$ >>
-              in
-              q mty qvars, mk_abst (mk_return (mk_app base args)) absts
-            in
-
-            let mk_non_method name loc ty =
-              let id = <:expr@loc< $lid:name$ >> in
-              let poly_type, expr = wrap_oo id ty in
-              <:str_item@loc<
-                let $lid:name$ : $poly_type$ = $expr$
+            classes := class_expr :: !classes;
+            let sitems' = <:str_item<
+                      $non_meths$
               >>
             in
+            let meStr = <:module_expr@sloc< 
+                             struct 
+                               open $ <:ident< Autoapi . $lid:modname$ >> $ 
+                               $sitems'$ 
+                             end 
+              >> 
+            in
+            modules := <:str_item@mloc< module $modname$ = $meStr$ >> :: !modules;
 
-            let mk_method name loc ty_rest =
-              let id = <:expr@loc< $lid:name$ >> in
-              let poly_type, expr = wrap_oo <:expr@loc<$id$ t>> ty_rest in
-              <:class_str_item@loc<
-                  method $name$ : $poly_type$ = $expr$
-              >>
-            in
+          | _sitem -> ()) sitem;
+        let _loc = Loc.ghost in
 
-            let non_meths = concat_str_items 
-              (List.map (fun (name, loc, ty) -> mk_non_method name loc ty) non_meths)
-            in
-
-            let meths =
-              concat_class_str_items
-                (List.map (fun (name, loc, ty_rest) -> mk_method name loc ty_rest) meths)
-            in
-            let _loc = Loc.ghost in
-            let tname = "_" ^ modname in
-            let tnametyp = <:ctyp< $lid:tname$ >> in
-            let sitems' = <:str_item<
-                      $non_meths$
-                      class $lid:tname$ 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$ >>
-
-        | sitem -> sitem
+        let class_defs = concat_class_exprs (List.rev !classes) in
+        <:str_item@_loc< 
+          open Type
+          $ class_defs $
+          $ concat_str_items (List.rev !modules) $
+        >>
+            
     end
-    in AstFilters.register_str_item_filter simplify#str_item
+    in AstFilters.register_str_item_filter wrap#str_item
 
 end
 

File type.ml

View file
 
 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