From: Pierre Habouzit <madcoder@debian.org>
Date: Sun, 25 Mar 2007 23:02:04 +0000 (+0200)
Subject: Use proper tools when we want to do powerful things.
X-Git-Url: http://git.madism.org/?p=apps%2Fmadmutt.git;a=commitdiff_plain;h=07f92763f437c569cd9994154fc367c66279e21a;ds=sidebyside

Use proper tools when we want to do powerful things.

  * exit perl the dumbass. Have a bindings ocaml(lex) generator. Distributed
    tarballs will contain the generated files so that having ocaml is not
    absolutely required.

  * for now on, guess how to compile it...
    (hint: ocamllex cpkg2c.mll; ocamlopt -o cpkg2c str.cmxa cpkg2c.ml)

There has been many improvements wrt the old perl thing, so it won't work on
current cpkg files yet.

Signed-off-by: Pierre Habouzit <madcoder@debian.org>
---

diff --git a/tools/cpkg2c.mll b/tools/cpkg2c.mll
new file mode 100644
index 0000000..3ec98ea
--- /dev/null
+++ b/tools/cpkg2c.mll
@@ -0,0 +1,526 @@
+(*
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or (at
+ *  your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful, but
+ *  WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ *  General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
+ *
+ *  Copyright © 2007 Pierre Habouzit
+ *)
+{
+  open Printf
+  module L = Lexing
+  module H = Hashtbl
+  module B = Buffer
+
+  type 'a anchor = ('a * string * int)
+
+  let t1 (a, _, _) = a
+  let t2 (_, a, _) = a
+  let t3 (_, _, a) = a
+
+  let die lpos fpos s =
+    output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
+    exit 1
+
+  let put_line = printf "#line %d \"%s\"\n"
+
+(* @types related {{{ *)
+
+  type typedef =
+    { lpos: int; fpos: string;
+      ctype: string anchor;
+      check: string anchor;
+      push : string anchor;
+      ctor : string anchor option;
+      dtor : string anchor option;
+    }
+  let typedef0 =
+    { lpos  = 0; fpos = "";
+      ctype = ("", "", 0);
+      check = ("", "", 0);
+      push  = ("", "", 0);
+      ctor  = None;
+      dtor = None
+    }
+  let types = H.create 1031
+
+
+  let (@:=) id  t =
+    List.iter (function ((s,_,_), x) -> if String.length s == 0 then
+      die t.lpos t.fpos (sprintf "type `%s' has no `%s' set" id x))
+    [(t.ctype, "ctype"); (t.check, "check"); (t.push, "push")];
+    H.add types id t
+
+(* }}} *)
+(* @packages related {{{ *)
+
+  type typinst = bool * typedef
+
+  type members =
+    { typ: typinst; mname: string; init: string }
+
+  type methods =
+    { rettype: typinst list; args: (typinst * string) list;
+      fname: string; body: string }
+
+  type package =
+    { line: int; file: string; name: string;
+      members: members anchor list;
+      methods: methods anchor list;
+      static: bool;
+    }
+
+  let newpkg lpos fpos name static =
+    { static = static; line = lpos; file = fpos; name = name; members = []; methods = []; }
+
+  let type_find lpos fpos t =
+    try Hashtbl.find types t
+    with Not_found -> die lpos fpos (sprintf "Unknown type `%s'" t)
+
+  let parse_rettype lpos fpos s =
+    let aux t =
+      match Str.split (Str.regexp "[ \t]+") t with
+      | ["const"; t] -> (true,  type_find lpos fpos t)
+      | [t]          -> (false, type_find lpos fpos t)
+      | _ -> assert false
+    in
+    match s with
+    | "void" -> []
+    | s      -> List.map aux (Str.split (Str.regexp "[ \t]+,[ \t]+") s)
+
+  let parse_args lpos fpos s =
+    let aux t =
+      match Str.split (Str.regexp "[ \t]+") t with
+      | ["const"; t; n] -> ((true,  type_find lpos fpos t), n)
+      | [t; n]          -> ((false, type_find lpos fpos t), n)
+      | _ -> assert false
+    in
+    match s with
+    | "void" -> []
+    | s      -> List.map aux (Str.split (Str.regexp "[ \t]+,[ \t]+") s)
+
+(* }}} *)
+(* parsing helpers {{{ *)
+
+  type stanza = Buf of string anchor | Pkg of package
+
+  let nextl lexbuf =
+    let pos = lexbuf.L.lex_curr_p in
+    lexbuf.L.lex_curr_p <-
+      { pos with
+        L.pos_lnum = pos.L.pos_lnum + 1;
+        L.pos_bol  = pos.L.pos_cnum; };
+    lexbuf
+  ;;
+
+  let lnum lexbuf = lexbuf.L.lex_curr_p.L.pos_lnum
+
+  let (@.)  buf s = B.add_string buf s; buf
+  let (@<)  buf c = B.add_char   buf c; buf
+
+  let getchunk lpos fpos buf lexbuf =
+    let res = B.contents buf in
+    B.clear buf;
+    Buf(res, fpos, lpos)
+
+  let startchunk f fpos lexbuf =
+    f (lnum lexbuf) fpos (B.create 4096) lexbuf
+
+  let newchunk f lpos fpos buf lexbuf =
+    let res = getchunk lpos fpos buf lexbuf in
+    res::(f (lnum lexbuf, fpos) buf lexbuf)
+
+  let find_import relpath file =
+    if Filename.is_relative file then
+      Filename.concat (Filename.dirname relpath) file
+    else
+      file
+
+(* }}} *)
+}
+
+(* regex aliases {{{ *)
+
+let to_eol = [^'\n']* '\n'
+let ident  = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''_''0'-'9']*
+let sp     = [' ''\t']
+
+let typdecl = sp* ("const" sp+)? ident sp*
+
+(* }}} *)
+
+(* entry point {{{ *)
+
+rule cLine lpos fpos buf = parse
+| sp* "@type" sp+ (ident as id) sp* (':' sp* (ident as id0) sp*)? '{'
+                    {
+                      let line = lnum lexbuf in
+                      let t0 = match id0 with
+                      | None     -> typedef0
+                      | Some id0 ->
+                          try H.find types id0
+                          with Not_found ->
+                            die line fpos (sprintf "Uknown type `%s'" id0)
+                      in try
+                        let t = H.find types id in
+                        die line fpos
+                          (sprintf "type `%s' already defined at %s:%d"
+                            id t.fpos t.lpos)
+                      with Not_found ->
+                        (getchunk lpos fpos buf lexbuf) :: (
+                          ext_type id {t0 with lpos = line; fpos = fpos}
+                            lexbuf
+                        )
+                    }
+| sp* "@import" sp+ '"' ([^'"''\n']* as file) '"' sp* '\n'
+                    {
+                      let file = find_import fpos file in
+                      let _ = startchunk cLine file
+                                (L.from_channel (open_in file)) in
+                      cLine lpos fpos (buf @< '\n') (nextl lexbuf)
+                    }
+| sp* ("@package"|"@static_package" as kw) sp+ (ident as pkg) sp* '{'
+                    {
+                      let a = getchunk lpos fpos buf lexbuf in
+                      let line = lnum lexbuf in
+                      a::(ext_pkg (newpkg line fpos pkg
+                                    (kw = "@static_package")) lexbuf)
+                    }
+| sp* '@'           { die (lnum lexbuf) fpos "Syntax error" }
+| sp* '#' as s      { let buf = cPP (buf @. s) lexbuf in
+                      cLine lpos fpos buf lexbuf }
+| ""                { let buf = cCode buf lexbuf in
+                      cLine lpos fpos buf lexbuf }
+| eof               { [getchunk lpos fpos buf lexbuf] }
+
+(* }}} *)
+(* cCode block parser {{{ *)
+
+and cCode buf = parse
+| '\n'    as c      { let _ = nextl lexbuf in buf @< c }
+| '"'     as c      { let buf = cString (buf @< c) lexbuf in
+                      cCode buf lexbuf }
+| "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
+                      cCode buf lexbuf }
+| "//" to_eol as s  { cCode (buf @. s) (nextl lexbuf) }
+| "'\"'"  as s      { cCode (buf @. s) lexbuf }
+| _       as c      { cCode (buf @< c) lexbuf }
+
+(* }}} *)
+(* helper rules: comment, string, cPP {{{ *)
+
+and cComment buf = parse
+| "*/"    as s { buf @. s }
+| '\n'    as c { cComment (buf @< c) (nextl lexbuf) }
+| _       as c { cComment (buf @< c) lexbuf }
+
+and cString buf = parse
+| '"'     as c { buf @< c }
+| "\\\""  as s { cString (buf @. s) lexbuf }
+| "\\\n"  as s { cString (buf @. s) (nextl lexbuf) }
+| [^'\n'] as c { cString (buf @< c) lexbuf }
+
+and cPP buf = parse
+| [^'\n']* "\\\n" as s { cPP (buf @. s) (nextl lexbuf) }
+| to_eol          as s { let _ = nextl lexbuf in buf @. s }
+
+(* }}} *)
+(* parse @type {{{ *)
+
+and ext_type id typ = parse
+| sp+
+| "//" to_eol       { ext_type id typ lexbuf }
+| '\n'              { ext_type id typ (nextl lexbuf) }
+| "/*"              { let _ = cComment (B.create 1024) lexbuf in
+                      ext_type id typ lexbuf }
+| '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
+                    {
+                      ext_type id (
+                        let do_anch s = s, typ.fpos, lnum lexbuf in
+                        match member with
+                        | "ctype" -> {typ with ctype = do_anch s}
+                        | "check" -> {typ with check = do_anch s}
+                        | "push"  -> {typ with push  = do_anch s}
+                        | "ctor"  -> {typ with ctor  = Some (do_anch s)}
+                        | "dtor"  -> {typ with dtor  = Some (do_anch s)}
+                        | _       ->
+                            die (lnum lexbuf) typ.fpos
+                              (sprintf "Unknown directive `%s'" member)
+                      ) lexbuf
+                    }
+| '}' sp* ';' (sp* '\n' as s)?
+                    { id @:= typ; startchunk cLine typ.fpos
+                      (if s = None then lexbuf else nextl lexbuf) }
+| ""                { die (lnum lexbuf) typ.fpos "Syntax error" }
+
+(* }}} *)
+(* parse @package {{{ *)
+
+and ext_pkg pkg = parse
+| sp+
+| "//" to_eol       { ext_pkg pkg lexbuf }
+| '\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* ([^';''\n']* as init)';'
+                    {
+                      let m = { typ   = const != None,
+                                        type_find (lnum lexbuf) pkg.file typ;
+                                mname = member;
+                                init  = init; }, pkg.file, lnum lexbuf in
+                      ext_pkg {pkg with members = m::pkg.members} lexbuf
+                    }
+| '(' ((typdecl ',')* typdecl as ret) ')' sp*
+   (ident as fname)
+   '('((typdecl ident sp* ',')* typdecl ident sp* as args)')'
+| (typdecl as ret) (ident as fname)
+   '('((typdecl ident sp* ',')* typdecl ident sp* as args)')'
+                    {
+                      let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
+                      let args    = parse_args    (lnum lexbuf) pkg.file args 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
+                      ext_pkg {pkg with methods = m::pkg.methods} lexbuf
+                    }
+| '}' sp* ';' (sp* '\n' as s)?
+                    { Pkg({pkg with members = List.rev(pkg.members)}) :: (
+                        startchunk cLine pkg.file
+                        (if s = None then lexbuf else nextl lexbuf)
+                      )
+                    }
+| ""                { die (lnum lexbuf) pkg.file "Syntax error" }
+
+and ext_body pkg buf = parse
+| sp+         as s
+| "//" to_eol as s  { ext_body pkg (buf @. s) lexbuf }
+| '\n'        as c  { ext_body pkg (buf @< c) lexbuf }
+| "/*"              { let buf = cComment (buf @. "/*") lexbuf in
+                      ext_body pkg buf lexbuf }
+| ';'               { B.contents buf }
+| '{'         as c  { let buf = ext_bodycode (buf @< c) lexbuf in
+                      ext_body pkg buf lexbuf }
+| ""                { die (lnum lexbuf) pkg.file "Syntax error" }
+
+and ext_bodycode buf = parse
+| '\n'    as c      { ext_bodycode (buf @< c) (nextl lexbuf) }
+| '"'     as c      { let buf = cString (buf @< c) lexbuf in
+                      ext_bodycode buf lexbuf }
+| "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
+                      ext_bodycode buf lexbuf }
+| "//" to_eol as s  { ext_bodycode (buf @. s) (nextl lexbuf) }
+| "'\"'"  as s      { ext_bodycode (buf @. s) lexbuf }
+| '{'     as c      { let buf = ext_bodycode (buf @< c) lexbuf in ext_bodycode buf lexbuf }
+| '}'     as c      { buf @< c }
+| _       as c      { ext_bodycode (buf @< c) lexbuf }
+
+(* }}} *)
+
+{
+  let upper = String.capitalize
+  let tplize tpl v =
+    Str.global_replace (Str.regexp_string "$L") "L" (
+      Str.global_replace (Str.regexp_string "$$") v tpl
+    )
+
+  let dump_struct_type begwith pkg endwith =
+    printf "%sstrict luaM_%s_t {\n" begwith pkg.name;
+    List.iter (function (m, f, l) ->
+      put_line l f;
+      let ctype = t1 (snd m.typ).ctype in
+      print_string "    ";
+      if fst m.typ then print_string "const ";
+      let i = try String.index ctype ':' with Not_found -> String.length ctype in
+      printf "%s %s%s;\n" (Str.string_before ctype i)
+        m.mname (Str.string_after ctype i)
+    ) pkg.members;
+    print_endline ("}" ^ endwith)
+
+  let do_h =
+    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);
+          if not pkg.static then dump_struct_type "" pkg ";";
+          printf "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
+          printf "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
+    in List.iter do_h_aux
+
+  let do_func pkg (fn, f, l) = 
+    printf "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
+    let i = ref 0 in
+    List.iter (function ((const, typ), name) ->
+      incr i;
+      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))
+      ) 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))
+        | 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)
+      )
+    ) fn.args;
+    printf "}\n"
+
+  let do_c =
+    let do_c_aux = function
+      | Buf (s, f, l) -> printf "#line %d %s\n%s" l f s
+      | Pkg pkg       ->
+          (* dump struct const init *)
+          (if pkg.static then
+            dump_struct_type "static" pkg (sprintf " %s = {\n" pkg.name)
+          else
+            printf "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")
+            ) pkg.members;
+          printf "};\n";
+
+          (* dump struct init func *)
+          printf "\nstatic void %s_init(void)\n{\n" pkg.name;
+          List.iter (function (m, f, l) ->
+            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";
+
+          (* 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";
+          List.iter (function (m, _, _) ->
+            printf "      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"
+          ) pkg.members;
+          printf "        lua_rawget(L, lua_upvalueindex(2));\n";
+          printf "        return 1;\n";
+          printf "    }\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";
+          List.iter (function (m, _, _) ->
+            let t = snd m.typ in
+            printf "      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))
+            );
+            (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")
+            | 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)
+            );
+            printf "        return 1;\n"
+          ) pkg.members;
+          printf "      default:\n";
+          printf "        return 1;\n";
+          printf "    }\n}\n";
+
+          (* dump methods *)
+          List.iter (do_func pkg) pkg.methods;
+          printf "\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)
+            pkg.methods;
+          print_string (Str.global_replace (Str.regexp "%s") pkg.name
+"    { NULL, NULL };
+};
+
+int luaopen_%s(lua_State *L)
+{
+    int mt, methods;
+
+    %s_init();
+
+    /* create methods table, add it the the table of globals */
+    luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
+    methods = 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_rawset(L, mt);                          /* set mt.__index    */
+
+    lua_pushliteral(L, \"__newindex\");
+    lua_newtable(L);                            /* for new members   */
+    lua_pushcclosure(L, &luaM_%s_newindex, 1);
+    lua_rawset(L, mt);                          /* set mt.__newindex */
+
+    lua_pushliteral(L, \"__metatable\");
+    lua_pushvalue(L, methods);                  /* dup methods table */
+    lua_rawset(L, mt);                          /* hide metatable    */
+
+    lua_setmetatable(L, methods);
+
+    lua_pop(L, 1);                              /* drop mt           */
+    return 1;                                   /* return methods    */
+}
+
+")
+    in List.iter do_c_aux
+
+  let usage () =
+    print_string "usage: cpkg2c (-h | -c) file.cpkg";
+    print_newline();
+    exit 1
+
+  let _ =
+    let warn () = print_endline "/*** THIS FILE IS AUTOGENERATED !!! ***/" in
+    if Array.length Sys.argv <= 2 then usage();
+    let file   = Sys.argv.(2) 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 ()
+}