module H = Hashtbl
module B = Buffer
- type 'a anchor = ('a * string * int)
-
+ 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"
+ 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 {{{ *)
}
let typedef0 =
{ lpos = 0; fpos = "";
- ctype = ("", "", 0);
- check = ("", "", 0);
- push = ("", "", 0);
+ ctype = "", "", 0;
+ check = "", "", 0;
+ push = "", "", 0;
ctor = None;
dtor = None
}
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;
| [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 =
| [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 {{{ *)
let typdecl = sp* ("const" sp+)? ident sp*
(* }}} *)
-
(* entry point {{{ *)
rule cLine lpos fpos buf = 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*
{
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)?
| '}' 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" }
+
(* }}} *)
{
+(* templating functions {{{ *)
+
let upper = String.uppercase
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 "%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();
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 */
lua_setmetatable(L, methods);
- lua_pop(L, 1); /* drop mt */
- return 1; /* return methods */
+ lua_pop(L, 3);
+ return 1;
}
")
in List.iter do_c_aux
+(* }}} *)
+
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
}
projects / apps / madmutt.git / blobdiff