X-Git-Url: http://git.madism.org/?p=apps%2Fmadmutt.git;a=blobdiff_plain;f=tools%2Fcpkg2c.mll;h=388973a06b126cc5904ac34f72294eafb1def280;hp=b33cf84c0db16f4ca8297ceba4f08f4f0087594a;hb=981e10e224fde4de5d40adcee1deda89df2715ca;hpb=597020b9829312a50c15784916f473da9e75efd0

diff --git a/tools/cpkg2c.mll b/tools/cpkg2c.mll
index b33cf84..388973a 100644
--- a/tools/cpkg2c.mll
+++ b/tools/cpkg2c.mll
@@ -29,7 +29,17 @@
     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 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;
+    while (isspace s.[!r - 1] && !l < !r) do decr r done;
+    String.sub s !l (!r - !l)
 
 (* @types related {{{ *)
 
@@ -43,9 +53,9 @@
     }
   let typedef0 =
     { lpos  = 0; fpos = "";
-      ctype = ("", "", 0);
-      check = ("", "", 0);
-      push  = ("", "", 0);
+      ctype = "", "", 0;
+      check = "", "", 0;
+      push  = "", "", 0;
       ctor  = None;
       dtor = None
     }
@@ -64,7 +74,14 @@
   type typinst = bool * typedef
 
   type members =
-    { typ: typinst; mname: string; init: string }
+    { typ: typinst; mname: string;
+      init: string anchor; onchange: string anchor option; }
+  let member0 =
+    { typ   = false, typedef0;
+      mname = "";
+      init = "", "", 0;
+      onchange = None;
+    }
 
   type methods =
     { rettype: typinst list; args: (typinst * string) list;
@@ -91,9 +108,9 @@
       | [t]          -> (false, type_find lpos fpos t)
       | _ -> assert false
     in
-    match s with
+    match strip s with
     | "void" -> []
-    | s      -> List.map aux (Str.split (Str.regexp "[ \t]+,[ \t]+") s)
+    | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
 
   let parse_args lpos fpos s =
     let aux t =
@@ -102,9 +119,9 @@
       | [t; n]          -> ((false, type_find lpos fpos t), n)
       | _ -> assert false
     in
-    match s with
+    match strip s with
     | "void" -> []
-    | s      -> List.map aux (Str.split (Str.regexp "[ \t]+,[ \t]+") s)
+    | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
 
 (* }}} *)
 (* parsing helpers {{{ *)
@@ -270,13 +287,23 @@ and ext_pkg pkg = parse
 | '\n'              { ext_pkg pkg (nextl lexbuf) }
 | "/*"              { let _ = cComment (B.create 1024) lexbuf in
                       ext_pkg pkg lexbuf }
+| ("const" sp+ as const)? (ident as typ) sp+
+  (ident as member) sp* '=' sp* '{'
+                    {
+                      let m = {member0 with mname = member;
+                               typ = const != None, type_find (lnum lexbuf)
+                               pkg.file typ; } in
+                      let m = ext_member m pkg.file lexbuf in
+                      ext_pkg {pkg with members = (m, pkg.file, lnum lexbuf)::pkg.members} lexbuf
+                    }
 | ("const" sp+ as const)? (ident as typ) sp+
   (ident as member) sp* '=' sp* ([^';''\n']* as init)';'
                     {
                       let m = { typ   = const != None,
                                         type_find (lnum lexbuf) pkg.file typ;
                                 mname = member;
-                                init  = init; }, pkg.file, lnum lexbuf in
+                                init  = init, pkg.file, lnum lexbuf;
+                                onchange = None; }, pkg.file, lnum lexbuf in
                       ext_pkg {pkg with members = m::pkg.members} lexbuf
                     }
 | '(' ((typdecl ',')* typdecl as ret) ')' sp*
@@ -287,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 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;
-                                      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)?
@@ -325,6 +353,30 @@ and ext_bodycode buf = parse
 | '}'     as c      { buf @< c }
 | _       as c      { ext_bodycode (buf @< c) lexbuf }
 
+(* }}} *)
+(* parse extended member {{{ *)
+
+and ext_member m f = parse
+| sp+
+| "//" to_eol       { ext_member m f lexbuf }
+| '\n'              { ext_member m f (nextl lexbuf) }
+| "/*"              { let _ = cComment (B.create 1024) lexbuf in
+                      ext_member m f lexbuf }
+| '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
+                    {
+                      ext_member (
+                        let do_anch s = s, f, lnum lexbuf in
+                        match member with
+                        | "init"     -> {m with init = do_anch s}
+                        | "onchange" -> {m with onchange = Some(do_anch s)}
+                        | _       ->
+                            die (lnum lexbuf) f
+                              (sprintf "Unknown directive `%s'" member)
+                      ) f lexbuf
+                    }
+| '}' sp* ';'       { m }
+| ""                { die (lnum lexbuf) f "Syntax error" }
+
 (* }}} *)
 
 {
@@ -336,183 +388,199 @@ and ext_bodycode buf = parse
       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) ->
-      put_line l f;
+      put_line ob l f;
       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
-      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;
-    print_endline ("}" ^ endwith)
+    output_endline ob ("}" ^ endwith)
 
-  let do_h =
+  let do_h ob =
     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 (
-            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
 
-  let do_func pkg (fn, f, l) = 
+  let do_func ob pkg (fn, f, l) = 
     (* 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
-      | 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
-    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
-      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) ->
-            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) ;
-    printf "    return %d;\n}\n" retlen;
+    fprintf ob "    return %d;\n}\n" retlen;
 
     (* 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
-        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
-          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
-          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);
-    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 (
-      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 (
-      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
-      | 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
-            dump_struct_type "static " pkg (sprintf " %s = {\n" pkg.name)
+            dump_struct_type ob "static " pkg (sprintf " %s = {\n" pkg.name)
           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, f, l) ->
-              put_line l f;
-              printf "    %s,\n" (if fst m.typ then m.init else "0")
+          List.iter (function (m, _, _) ->
+              let (init, f, l) = m.init in
+              put_line ob l f;
+              fprintf ob "    %s,\n" (if fst m.typ then init else "0")
             ) pkg.members;
-          printf "};\n";
+          fprintf ob "};\n";
 
           (* dump struct init func *)
-          printf "\nstatic void %s_init(void)\n{\n" pkg.name;
-          List.iter (function (m, f, l) ->
+          fprintf ob "\nstatic void (%s_init)(void)\n{\n" pkg.name;
+          List.iter (function (m, _, _) ->
             if not (fst m.typ) then
-              printf "#line %d \"%s\"\n    %s.%s = %s;\n"
-              l f pkg.name m.mname m.init) pkg.members;
-          printf "};\n\n";
+              let init, f, l = m.init in
+              let field = sprintf "%s.%s" pkg.name m.mname in
+              put_line ob l f;
+              fprintf ob "    %s = %s;\n" field init;
+              match m.onchange with
+              | None           -> ()
+              | Some(on, f, l) ->
+                  put_line ob l f; fprintf ob "    %s;\n" (tplize on field)
+            ) pkg.members;
+          fprintf ob "};\n\n";
 
           (* 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";
-          printf "      default:\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, _, _) ->
-            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
-            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;
-          printf "        lua_rawget(L, lua_upvalueindex(2));\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 *)
-          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 ->
-              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) ->
-                  put_line l f;
-                  printf "        %s;\n" (tplize dtor (sprintf "&%s.%s" pkg.name m.mname))
+                  put_line ob l f;
+                  fprintf ob "        %s;\n" (tplize dtor ("&" ^ field))
               );
               (match t.ctor with
               | None ->
                   let (c, f, l) = t.check in
-                  put_line l f;
-                  printf "        %s.%s = %s;\n" pkg.name m.mname (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
-                  put_line l f;
-                  printf "        %s.%s = %s;\n" pkg.name m.mname (tplize ctor v)
+                  put_line ob l f;
+                  fprintf ob "        %s = %s;\n" field (tplize ctor v)
               );
-              printf "        return 1;\n"
+              (match m.onchange with
+              | None           -> ()
+              | Some(on, f, l) ->
+                  put_line ob l f;
+                  fprintf ob "        %s;\n" (tplize on field)
+              );
+              fprintf ob "        return 1;\n"
           ) pkg.members;
-          printf "      default:\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 *)
-          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, _, _) ->
-              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;
-          print_string (Str.global_replace (Str.regexp "%s") pkg.name
+          output_string ob (Str.global_replace (Str.regexp "%s") pkg.name
 "    { NULL, NULL },
 };
 
 int luaopen_%s(lua_State *L)
 {
-    int mt, methods;
+    int mt, members, methods;
 
     %s_init();
 
@@ -520,18 +588,20 @@ int luaopen_%s(lua_State *L)
     luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
     methods = lua_gettop(L);
 
+    lua_newtable(L);                            /* for new members   */
+    members = lua_gettop(L);
+
     /* create metatable for %s, add it to the registry */
     luaL_newmetatable(L, \"%s\");
     mt = lua_gettop(L);
 
-    lua_pushliteral(L, \"%s\");
-    lua_pushvalue(L, mt);                       /* upvalue 1         */
-    lua_pushvalue(L, methods);                  /* upvalue 2         */
-    lua_pushcclosure(L, &luaM_%s_index, 2);
+    lua_pushliteral(L, \"__index\");
+    lua_pushvalue(L, members);                  /* upvalue  1        */
+    lua_pushcclosure(L, &luaM_%s_index, 1);
     lua_rawset(L, mt);                          /* set mt.__index    */
 
     lua_pushliteral(L, \"__newindex\");
-    lua_newtable(L);                            /* for new members   */
+    lua_pushvalue(L, members);                  /* upvalue  1        */
     lua_pushcclosure(L, &luaM_%s_newindex, 1);
     lua_rawset(L, mt);                          /* set mt.__newindex */
 
@@ -541,8 +611,8 @@ int luaopen_%s(lua_State *L)
 
     lua_setmetatable(L, methods);
 
-    lua_pop(L, 1);                              /* drop mt           */
-    return 1;                                   /* return methods    */
+    lua_pop(L, 3);
+    return 1;
 }
 
 ")
@@ -551,17 +621,21 @@ int luaopen_%s(lua_State *L)
 (* }}} *)
 
   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
 
+  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 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
-    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
 }