Simplifications.

[apps/madmutt.git] / tools / cpkg2c.mll

diff --git a/tools/cpkg2c.mll b/tools/cpkg2c.mll
index 82be124..388973a 100644 (file)
--- a/tools/cpkg2c.mll
+++ b/tools/cpkg2c.mll
@@ -29,10 +29,12 @@
     output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
     exit 1
 
     output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
     exit 1
 

-  let put_line = printf "#line %d \"%s\"\n"
+  let put_line ob = fprintf ob "#line %d \"%s\"\n"

 
   let isspace = function |' '|'\t' -> true | _ -> false
 
 
   let isspace = function |' '|'\t' -> true | _ -> false
 

+  let output_endline ob s = output_string ob s; output_char ob '\n'
+

   let strip s =
     let l = ref 0 and r = ref (String.length s) in
     while (isspace s.[!l]     && !l < !r) do incr l done;
   let strip s =
     let l = ref 0 and r = ref (String.length s) in
     while (isspace s.[!l]     && !l < !r) do incr l done;


@@ -312,11 +314,12 @@ and ext_pkg pkg = parse
                     {
                       let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
                       let args    = parse_args    (lnum lexbuf) pkg.file args in
                     {
                       let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
                       let args    = parse_args    (lnum lexbuf) pkg.file args in

+                      let f, l    = pkg.file, lnum lexbuf in

                       let body    = ext_body pkg (B.create 1024) lexbuf in
                       let m       = { rettype = rettype;
                                       args = args;
                                       fname = fname;
                       let body    = ext_body pkg (B.create 1024) lexbuf in
                       let m       = { rettype = rettype;
                                       args = args;
                                       fname = fname;

-                                      body = body }, pkg.file, lnum lexbuf in
+                                      body = body }, f, l in

                       ext_pkg {pkg with methods = m::pkg.methods} lexbuf
                     }
 | '}' sp* ';' (sp* '\n' as s)?
                       ext_pkg {pkg with methods = m::pkg.methods} lexbuf
                     }
 | '}' sp* ';' (sp* '\n' as s)?


@@ -385,193 +388,193 @@ and ext_member m f = parse
       Str.global_replace (Str.regexp_string "$$") v tpl
     )
 
       Str.global_replace (Str.regexp_string "$$") v tpl
     )
 

-  let dump_struct_type begwith pkg endwith =
-    printf "%sstruct luaM_%s_t {\n" begwith pkg.name;
+  let dump_struct_type ob begwith pkg endwith =
+    fprintf ob "%sstruct luaM_%s_t {\n" begwith pkg.name;

     List.iter (function (m, f, l) ->
     List.iter (function (m, f, l) ->

-      put_line l f;
+      put_line ob l f;

       let ctype = t1 (snd m.typ).ctype in
       let ctype = t1 (snd m.typ).ctype in

-      print_string "    ";
-      if fst m.typ then print_string "const ";
+      output_string ob "    ";
+      if fst m.typ then output_string ob "const ";

       let i = try String.index ctype ':' with Not_found -> String.length ctype in
       let i = try String.index ctype ':' with Not_found -> String.length ctype in

-      printf "%s %s%s;\n" (Str.string_before ctype i)
+      fprintf ob "%s %s%s;\n" (Str.string_before ctype i)

         m.mname (Str.string_after ctype i)
     ) pkg.members;
         m.mname (Str.string_after ctype i)
     ) pkg.members;

-    print_endline ("}" ^ endwith)
+    output_endline ob ("}" ^ endwith)

 
 

-  let do_h =
+  let do_h ob =

     let do_h_aux = function
       | Buf _ -> ()
       | Pkg pkg ->
     let do_h_aux = function
       | Buf _ -> ()
       | Pkg pkg ->

-          printf "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
-          printf "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);
+          fprintf ob "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
+          fprintf ob "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);

           if not pkg.static then (
           if not pkg.static then (

-            dump_struct_type "" pkg ";";
-            printf "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;
+            dump_struct_type ob "" pkg ";";
+            fprintf ob "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;

           );
           );

-          printf "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
-          printf "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
+          fprintf ob "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
+          fprintf ob "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);

     in List.iter do_h_aux
 
     in List.iter do_h_aux
 

-  let do_func pkg (fn, f, l) = 
+  let do_func ob pkg (fn, f, l) = 

     (* return inline function *)
     (* return inline function *)

-    printf "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;
+    fprintf ob "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;

     let retlen = List.fold_left (fun i t ->
       let i = i + 1 in
       match t with
     let retlen = List.fold_left (fun i t ->
       let i = i + 1 in
       match t with

-      | true, typ -> printf ", const %s luaM_x%d" (t1 typ.ctype) i; i
-      | false, typ -> printf ", %s luaM_x%d" (t1 typ.ctype) i; i
+      | true, typ -> fprintf ob ", const %s luaM_x%d" (t1 typ.ctype) i; i
+      | false, typ -> fprintf ob ", %s luaM_x%d" (t1 typ.ctype) i; i

       ) 0 fn.rettype in
       ) 0 fn.rettype in

-    printf ")\n{\n";
+    fprintf ob ")\n{\n";

     ignore (List.fold_left (fun i (const, typ) ->
       let i = i + 1 in
       let (p, f, l) = typ.push in
     ignore (List.fold_left (fun i (const, typ) ->
       let i = i + 1 in
       let (p, f, l) = typ.push in

-      put_line l f;
-      printf "    %s;\n" (tplize p (sprintf "luaM_x%d" i));
+      put_line ob l f;
+      fprintf ob "    %s;\n" (tplize p (sprintf "luaM_x%d" i));

       if not const then (
         match typ.dtor with
         | None             -> ()
         | Some(dtor, f, l) ->
       if not const then (
         match typ.dtor with
         | None             -> ()
         | Some(dtor, f, l) ->

-            put_line l f;
-            printf "    %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))
+            put_line ob l f;
+            fprintf ob "    %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))

       ); i
     ) 0 fn.rettype) ;
       ); i
     ) 0 fn.rettype) ;

-    printf "    return %d;\n}\n" retlen;
+    fprintf ob "    return %d;\n}\n" retlen;

 
     (* main function *)
 
     (* main function *)

-    printf "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
+    fprintf ob "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;

     ignore (List.fold_left (fun i ((const, typ), name) ->
       let i = i + 1 in
       let ctype = t1 typ.ctype in
       if const then (
         let (c, f, l) = typ.check in
     ignore (List.fold_left (fun i ((const, typ), name) ->
       let i = i + 1 in
       let ctype = t1 typ.ctype in
       if const then (
         let (c, f, l) = typ.check in

-        put_line l f;
-        printf "    const %s %s = %s;\n" ctype name (tplize c (string_of_int i))
+        put_line ob l f;
+        fprintf ob "    const %s %s = %s;\n" ctype name (tplize c (string_of_int i))

       ) else (
         match typ.ctor with
         | None ->
           let (c, f, l) = typ.check in
       ) else (
         match typ.ctor with
         | None ->
           let (c, f, l) = typ.check in

-          put_line l f;
-          printf "    %s %s = %s;\n" ctype name (tplize c (string_of_int i))
+          put_line ob l f;
+          fprintf ob "    %s %s = %s;\n" ctype name (tplize c (string_of_int i))

         | Some (ctor, f, l) ->
           let v =
             let c, f, l = typ.check in
             tplize (sprintf "\n#line %d \"%s\"\n        %s" l f c)
               (string_of_int i)
           in
         | Some (ctor, f, l) ->
           let v =
             let c, f, l = typ.check in
             tplize (sprintf "\n#line %d \"%s\"\n        %s" l f c)
               (string_of_int i)
           in

-          put_line l f;
-          printf "    %s %s = %s;\n" ctype name (tplize ctor v)
+          put_line ob l f;
+          fprintf ob "    %s %s = %s;\n" ctype name (tplize ctor v)

       ); i
     ) 0 fn.args);
       ); i
     ) 0 fn.args);

-    printf "\n#define RAISE(s)  luaL_error(L, (s))\n";
+    fprintf ob "\n#define RAISE(s)  luaL_error(L, (s))\n";

     if fn.rettype = [] then (
     if fn.rettype = [] then (

-      printf "#define RETURN()  return luaM_ret_%s_%s(L)\n" pkg.name fn.fname
+      fprintf ob "#define RETURN()  return luaM_ret_%s_%s(L)\n" pkg.name fn.fname

     ) else (
     ) else (

-      printf "#define RETURN(luaM_x1";
-      for i = 2 to retlen do printf ", luaM_x%d" i done;
-      printf ") \\\n        return luaM_ret_%s_%s(L" pkg.name fn.fname;
-      for i = 1 to retlen do printf ", luaM_x%d" i done;
-      printf ")\n"
+      fprintf ob "#define RETURN(luaM_x1";
+      for i = 2 to retlen do fprintf ob ", luaM_x%d" i done;
+      fprintf ob ") \\\n        return luaM_ret_%s_%s(L" pkg.name fn.fname;
+      for i = 1 to retlen do fprintf ob ", luaM_x%d" i done;
+      fprintf ob ")\n"

     );
     );

-    put_line l f;
-    printf "    %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body
+    put_line ob l f;
+    fprintf ob "    %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body

 
 

-  let do_c =
+  let do_c ob =

     let do_c_aux = function
     let do_c_aux = function

-      | Buf (s, f, l) -> put_line l f; print_string s
+      | Buf (s, f, l) -> put_line ob l f; output_string ob s

       | Pkg pkg       ->
           (* dump struct const init *)
           (if pkg.static then
       | Pkg pkg       ->
           (* dump struct const init *)
           (if pkg.static then

-            dump_struct_type "static " pkg (sprintf " %s = {\n" pkg.name)
+            dump_struct_type ob "static " pkg (sprintf " %s = {\n" pkg.name)

           else
           else

-            printf "struct luaM_%s_t %s = {\n" pkg.name pkg.name
+            fprintf ob "struct luaM_%s_t %s = {\n" pkg.name pkg.name

           );
           List.iter (function (m, _, _) ->
               let (init, f, l) = m.init in
           );
           List.iter (function (m, _, _) ->
               let (init, f, l) = m.init in

-              put_line l f;
-              printf "    %s,\n" (if fst m.typ then init else "0")
+              put_line ob l f;
+              fprintf ob "    %s,\n" (if fst m.typ then init else "0")

             ) pkg.members;
             ) pkg.members;

-          printf "};\n";
+          fprintf ob "};\n";

 
           (* dump struct init func *)
 
           (* dump struct init func *)

-          printf "\nstatic void %s_init(void)\n{\n" pkg.name;
+          fprintf ob "\nstatic void (%s_init)(void)\n{\n" pkg.name;

           List.iter (function (m, _, _) ->
             if not (fst m.typ) then
               let init, f, l = m.init in
               let field = sprintf "%s.%s" pkg.name m.mname in
           List.iter (function (m, _, _) ->
             if not (fst m.typ) then
               let init, f, l = m.init in
               let field = sprintf "%s.%s" pkg.name m.mname in

-              put_line l f;
-              printf "    %s = %s;\n" field init;
+              put_line ob l f;
+              fprintf ob "    %s = %s;\n" field init;

               match m.onchange with
               | None           -> ()
               | Some(on, f, l) ->
               match m.onchange with
               | None           -> ()
               | Some(on, f, l) ->

-                  put_line l f; printf "    %s;\n" (tplize on field)
+                  put_line ob l f; fprintf ob "    %s;\n" (tplize on field)

             ) pkg.members;
             ) pkg.members;

-          printf "};\n\n";
+          fprintf ob "};\n\n";

 
           (* dump __index *)
 
           (* dump __index *)

-          printf "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
-          printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
-          printf "    switch (mlua_which_token(idx, -1)) {\n";
+          fprintf ob "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
+          fprintf ob "    const char *idx = luaL_checkstring(L, 2);\n\n";
+          fprintf ob "    switch (mlua_which_token(idx, -1)) {\n";

           List.iter (function (m, _, _) ->
           List.iter (function (m, _, _) ->

-            printf "      case LTK_%s:\n" (upper m.mname);
+            fprintf ob "      case LTK_%s:\n" (upper m.mname);

             let push, f, l = (snd m.typ).push in
             let push, f, l = (snd m.typ).push in

-            put_line l f;
-            printf "        %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
-            printf "        return 1;\n"
+            put_line ob l f;
+            fprintf ob "        %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
+            fprintf ob "        return 1;\n"

           ) pkg.members;
           ) pkg.members;

-          printf "      default:\n";
-          printf "        lua_rawget(L, lua_upvalueindex(1));\n";
-          printf "        return 1;\n";
-          printf "    }\n}\n\n";
+          fprintf ob "      default:\n";
+          fprintf ob "        lua_rawget(L, lua_upvalueindex(1));\n";
+          fprintf ob "        return 1;\n";
+          fprintf ob "    }\n}\n\n";

 
           (* dump __newindex *)
 
           (* dump __newindex *)

-          printf "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
-          printf "    const char *idx = luaL_checkstring(L, 2);\n\n";
-          printf "    switch (mlua_which_token(idx, -1)) {\n";
+          fprintf ob "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
+          fprintf ob "    const char *idx = luaL_checkstring(L, 2);\n\n";
+          fprintf ob "    switch (mlua_which_token(idx, -1)) {\n";

           List.iter (function (m, _, _) ->
             let field = sprintf "%s.%s" pkg.name m.mname in
             match m.typ with
             | true, _ -> ()
             | false, t ->
           List.iter (function (m, _, _) ->
             let field = sprintf "%s.%s" pkg.name m.mname in
             match m.typ with
             | true, _ -> ()
             | false, t ->

-              printf "      case LTK_%s:\n" (upper m.mname);
+              fprintf ob "      case LTK_%s:\n" (upper m.mname);

               (match t.dtor with
               | None -> ()
               | Some (dtor, f, l) ->
               (match t.dtor with
               | None -> ()
               | Some (dtor, f, l) ->

-                  put_line l f;
-                  printf "        %s;\n" (tplize dtor ("&" ^ field))
+                  put_line ob l f;
+                  fprintf ob "        %s;\n" (tplize dtor ("&" ^ field))

               );
               (match t.ctor with
               | None ->
                   let (c, f, l) = t.check in
               );
               (match t.ctor with
               | None ->
                   let (c, f, l) = t.check in

-                  put_line l f;
-                  printf "        %s = %s;\n" field (tplize c "3")
+                  put_line ob l f;
+                  fprintf ob "        %s = %s;\n" field (tplize c "3")

               | Some (ctor, f, l) ->
                   let v =
                     let c, f, l = t.check in
                     tplize (sprintf "\n#line %d \"%s\"\n            %s" l f c) "3"
                   in
               | Some (ctor, f, l) ->
                   let v =
                     let c, f, l = t.check in
                     tplize (sprintf "\n#line %d \"%s\"\n            %s" l f c) "3"
                   in

-                  put_line l f;
-                  printf "        %s = %s;\n" field (tplize ctor v)
+                  put_line ob l f;
+                  fprintf ob "        %s = %s;\n" field (tplize ctor v)

               );
               (match m.onchange with
               | None           -> ()
               | Some(on, f, l) ->
               );
               (match m.onchange with
               | None           -> ()
               | Some(on, f, l) ->

-                  put_line l f;
-                  printf "        %s;\n" (tplize on field)
+                  put_line ob l f;
+                  fprintf ob "        %s;\n" (tplize on field)

               );
               );

-              printf "        return 1;\n"
+              fprintf ob "        return 1;\n"

           ) pkg.members;
           ) pkg.members;

-          printf "      default:\n";
-          printf "        lua_rawset(L, lua_upvalueindex(1));\n";
-          printf "        return 1;\n";
-          printf "    }\n}\n";
+          fprintf ob "      default:\n";
+          fprintf ob "        lua_rawset(L, lua_upvalueindex(1));\n";
+          fprintf ob "        return 1;\n";
+          fprintf ob "    }\n}\n";

 
           (* dump methods *)
 
           (* dump methods *)

-          List.iter (do_func pkg) pkg.methods;
-          printf "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;
+          List.iter (do_func ob pkg) pkg.methods;
+          fprintf ob "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;

           List.iter (function (f, _, _) ->
           List.iter (function (f, _, _) ->

-              printf "    { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)
+              fprintf ob "    { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)

             pkg.methods;
             pkg.methods;

-          print_string (Str.global_replace (Str.regexp "%s") pkg.name
+          output_string ob (Str.global_replace (Str.regexp "%s") pkg.name

 "    { NULL, NULL },
 };
 
 "    { NULL, NULL },
 };
 


@@ -618,17 +621,21 @@ int luaopen_%s(lua_State *L)
 (* }}} *)
 
   let usage () =
 (* }}} *)
 
   let usage () =

-    output_string stderr "usage: cpkg2c (-h | -c) file.cpkg\n";
+    output_string stderr "usage: cpkg2c file.cpkg header.out source.out\n";

     exit 1
 
     exit 1
 

+  let warn ob = output_endline ob "/*** THIS FILE IS AUTOGENERATED !!! ***/"
+
+  let process fn file l =
+    (try Unix.unlink file with _ -> ());
+    let ob = open_out_gen  [ Open_trunc ; Open_wronly; Open_creat ] 0o444 file in
+    warn ob; fn ob l; close_out ob
+

   let _ =
   let _ =

-    let warn () = print_endline "/*** THIS FILE IS AUTOGENERATED !!! ***/" in
-    if Array.length Sys.argv <= 2 then usage();
-    let file   = Sys.argv.(2) in
+    if Array.length Sys.argv != 4 then usage();
+    let file   = Sys.argv.(1) in

     let lexbuf = L.from_channel (open_in file) in
     let l      = (startchunk cLine file lexbuf) in
     let lexbuf = L.from_channel (open_in file) in
     let l      = (startchunk cLine file lexbuf) in

-    match Sys.argv.(1) with
-    | "-h" -> warn (); do_h l
-    | "-c" -> warn (); do_c l
-    | _    -> usage ()
+    process do_h Sys.argv.(2) l;
+    process do_c Sys.argv.(3) l

 }
 }