From 07f92763f437c569cd9994154fc367c66279e21a Mon Sep 17 00:00:00 2001 From: Pierre Habouzit Date: Mon, 26 Mar 2007 01:02:04 +0200 Subject: [PATCH] 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 --- tools/cpkg2c.mll | 526 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 526 insertions(+) create mode 100644 tools/cpkg2c.mll 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 () +} -- 2.20.1