--- /dev/null
+(*
+ * 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 ()
+}
projects / apps / madmutt.git / blobdiff