Commits

camlspotter committed 7f0a5ea

trial

  • Participants
  • Parent commits 3367eff

Comments (0)

Files changed (2)

 auto.ml auto.mli auto_stubs.c: $(addsuffix .idl, $(IDLS)) $(Installed camlidl) autoclasses.idl autoclasses.h
 	bash -c "camlidl auto.idl"
 
-autoapi.ml : auto.ml module.pl $(addsuffix .idl.in, $(IDLS))
+autoapi.mlp : auto.ml module.pl $(addsuffix .idl.in, $(IDLS))
     ./module.pl *.idl.in > $@
 
+autoapi.ml: autoapi.mlp pa/pa_opycaml.cmo
+    camlp4of ./pa/pa_opycaml.cmo -impl autoapi.mlp -printer Camlp4OCamlPrinter > $@
+
 auto_stubs.o: auto_stubs.c auto.h api_ml.h autoclasses.h
 
 clean:
       method! str_item sitem =
         let sitem = super#str_item sitem in
         match sitem with
-        | Ast.StMod (_loc, modname, module_expr) ->
+        | Ast.StMod (mloc, modname, module_expr) ->
             let rec iter_sitems f = function
               | Ast.StSem (_, sitem1, sitem2) -> iter_sitems f sitem1; iter_sitems f sitem2
               | i -> f i
             | Ast.MeStr (x, sitem) ->
                 let meths = ref [] in
                 iter_sitems (function
-                  | Ast.StExt (_, name, <:ctyp< [ > $cls$ ] t -> $_ret$>>, _slist) -> 
-(*
-                  | <:str_item< external $name$ : [ > $cls$ ] t -> $_$ = $_$>> ->     DOES NOT WORK...
-*)
+                  | Ast.StExt (loc, name, <:ctyp< [ > $cls$ ] t -> $ty_rest$>>, _slist) -> 
                       begin match cls with
                       | Ast.TyId (_, Ast.IdLid (_, tname)) ->
-                          if tname = "_" ^ modname then meths := name :: !meths
+                          if tname = "_" ^ modname then meths := (name, loc, ty_rest) :: !meths
                       | _ -> ()
                       end
                   | _ -> ()
                 ) sitem;
-                let create_meth name = 
-                  let lid = Ast.ExId (_loc, Ast.IdLid (_loc, name)) in
-                  <:class_str_item< method $name$ = $lid$ t >> 
+                let create_meth name loc ty_rest = 
+                  let rec args pos (f, st) = function
+                    | <:ctyp< $argty$ -> $ty$ >> ->
+                        let _loc = Ast.Loc.ghost in
+                        let vname = Printf.sprintf "v%d" pos in
+                        let v = <:expr<$lid:vname$>> in
+                        let e = 
+                          match argty with
+                          | <:ctyp< [ > $cls$ ] t >> -> 
+                              begin match cls with
+                              | Ast.TyId (_, Ast.IdLid (_, clsname)) ->
+                                  let tnametyp = <:ctyp< $lid: clsname$ >> in
+                                  <:expr< ($v$#$clsname$ : $tnametyp$ t) >>
+                              | _ -> <:expr< $v$#hoge >>
+                              end
+                          | _ -> v
+                        in
+                        args (pos+1) ( (fun e -> f (Ast.ExFun (Ast.Loc.ghost, Ast.McArr( Ast.Loc.ghost,
+                                                                                      Ast.PaId (Ast.Loc.ghost, Ast.IdLid (Ast.Loc.ghost, vname)),
+                                                                                      Ast.ExNil Ast.Loc.ghost,
+                                                                                      e)))), 
+                                       <:expr< $st$ $e$ >> ) ty
+                    | _ -> f st
+                  in
+                  let lid = Ast.ExId (loc, Ast.IdLid (loc, name)) in
+                  let _loc = Ast.Loc.ghost in
+                  let e = args 0 ((fun x -> x), <:expr<$lid$ t>>) ty_rest in
+                  <:class_str_item@loc< method $name$ = $e$ >> 
                 in
                 let meths = 
-                  List.fold_left (fun st name -> Ast.CrSem(_loc, create_meth name, st)) (Ast.CrNil _loc) !meths
+                  List.fold_left (fun st (name, loc, ty_rest) -> Ast.CrSem(loc, create_meth name loc ty_rest, st)) 
+                    (Ast.CrNil Ast.Loc.ghost) !meths
                 in
-                let sitem' = Ast.StSem (_loc, sitem, 
+                let _loc = Ast.Loc.ghost in
+                let tname = "_" ^ modname in
+                let tnametyp = <:ctyp< $lid:tname$ >> in
+                let sitem' = Ast.StSem (Ast.Loc.ghost, sitem, 
                                         <:str_item< class o t = object
-                                            $meths$
+                                          $meths$
+                                          method $tname$ = (t :> $tnametyp$ t )
                                         end>>)
                 in
-                Ast.StMod (_loc, modname, Ast.MeStr (x, sitem'))
+                Ast.StMod (mloc, modname, Ast.MeStr (x, sitem'))
             | _ -> sitem
             end
         | sitem -> sitem