2 * This program is free software; you can redistribute it and/or modify
3 * it under the terms of the GNU General Public License as published by
4 * the Free Software Foundation; either version 2 of the License, or (at
5 * your option) any later version.
7 * This program is distributed in the hope that it will be useful, but
8 * WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10 * General Public License for more details.
12 * You should have received a copy of the GNU General Public License
13 * along with this program; if not, write to the Free Software
14 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
17 * Copyright © 2007 Pierre Habouzit
25 type 'a anchor = ('a * string * int)
29 output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
32 let put_line ob = fprintf ob "#line %d \"%s\"\n"
34 let isspace = function |' '|'\t' -> true | _ -> false
36 let output_endline ob s = output_string ob s; output_char ob '\n'
39 let l = ref 0 and r = ref (String.length s) in
40 while (isspace s.[!l] && !l < !r) do incr l done;
41 while (isspace s.[!r - 1] && !l < !r) do decr r done;
42 String.sub s !l (!r - !l)
44 (* @types related {{{ *)
47 { lpos: int; fpos: string;
51 ctor : string anchor option;
52 dtor : string anchor option;
55 { lpos = 0; fpos = "";
62 let types = H.create 1031
66 List.iter (function ((s,_,_), x) -> if String.length s == 0 then
67 die t.lpos t.fpos (sprintf "type `%s' has no `%s' set" id x))
68 [(t.ctype, "ctype"); (t.check, "check"); (t.push, "push")];
72 (* @packages related {{{ *)
74 type typinst = bool * typedef
77 { typ: typinst; mname: string;
78 init: string anchor; onchange: string anchor option; }
80 { typ = false, typedef0;
87 { rettype: typinst list; args: (typinst * string) list;
88 fname: string; body: string }
91 { line: int; file: string; name: string;
92 members: members anchor list;
93 methods: methods anchor list;
97 let newpkg lpos fpos name static =
98 { static = static; line = lpos; file = fpos; name = name; members = []; methods = []; }
100 let type_find lpos fpos t =
101 try Hashtbl.find types t
102 with Not_found -> die lpos fpos (sprintf "Unknown type `%s'" t)
104 let parse_rettype lpos fpos s =
106 match Str.split (Str.regexp "[ \t]+") t with
107 | ["const"; t] -> (true, type_find lpos fpos t)
108 | [t] -> (false, type_find lpos fpos t)
113 | s -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
115 let parse_args lpos fpos s =
117 match Str.split (Str.regexp "[ \t]+") t with
118 | ["const"; t; n] -> ((true, type_find lpos fpos t), n)
119 | [t; n] -> ((false, type_find lpos fpos t), n)
124 | s -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)
127 (* parsing helpers {{{ *)
129 type stanza = Buf of string anchor | Pkg of package
132 let pos = lexbuf.L.lex_curr_p in
133 lexbuf.L.lex_curr_p <-
135 L.pos_lnum = pos.L.pos_lnum + 1;
136 L.pos_bol = pos.L.pos_cnum; };
140 let lnum lexbuf = lexbuf.L.lex_curr_p.L.pos_lnum
142 let (@.) buf s = B.add_string buf s; buf
143 let (@<) buf c = B.add_char buf c; buf
145 let getchunk lpos fpos buf lexbuf =
146 let res = B.contents buf in
150 let startchunk f fpos lexbuf =
151 f (lnum lexbuf) fpos (B.create 4096) lexbuf
153 let newchunk f lpos fpos buf lexbuf =
154 let res = getchunk lpos fpos buf lexbuf in
155 res::(f (lnum lexbuf, fpos) buf lexbuf)
157 let find_import relpath file =
158 if Filename.is_relative file then
159 match Filename.dirname relpath with
161 | s -> Filename.concat s file
168 (* regex aliases {{{ *)
170 let to_eol = [^'\n']* '\n'
171 let ident = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''_''0'-'9']*
174 let typdecl = sp* ("const" sp+)? ident sp*
177 (* entry point {{{ *)
179 rule cLine lpos fpos buf = parse
180 | sp* "@type" sp+ (ident as id) sp* (':' sp* (ident as id0) sp*)? '{'
182 let line = lnum lexbuf in
183 let t0 = match id0 with
188 die line fpos (sprintf "Uknown type `%s'" id0)
190 let t = H.find types id in
192 (sprintf "type `%s' already defined at %s:%d"
195 (getchunk lpos fpos buf lexbuf) :: (
196 ext_type id {t0 with lpos = line; fpos = fpos}
200 | sp* "@import" sp+ '"' ([^'"''\n']* as file) '"' sp* '\n'
202 let file = find_import fpos file in
203 let _ = startchunk cLine file
204 (L.from_channel (open_in file)) in
205 cLine lpos fpos (buf @< '\n') (nextl lexbuf)
207 | sp* ("@package"|"@static_package" as kw) sp+ (ident as pkg) sp* '{'
209 let a = getchunk lpos fpos buf lexbuf in
210 let line = lnum lexbuf in
211 a::(ext_pkg (newpkg line fpos pkg
212 (kw = "@static_package")) lexbuf)
214 | sp* '@' { die (lnum lexbuf) fpos "Syntax error" }
215 | sp* '#' as s { let buf = cPP (buf @. s) lexbuf in
216 cLine lpos fpos buf lexbuf }
217 | "" { let buf = cCode buf lexbuf in
218 cLine lpos fpos buf lexbuf }
219 | eof { [getchunk lpos fpos buf lexbuf] }
222 (* cCode block parser {{{ *)
224 and cCode buf = parse
225 | '\n' as c { let _ = nextl lexbuf in buf @< c }
226 | '"' as c { let buf = cString (buf @< c) lexbuf in
228 | "/*" as s { let buf = cComment (buf @. s) lexbuf in
230 | "//" to_eol as s { cCode (buf @. s) (nextl lexbuf) }
231 | "'\"'" as s { cCode (buf @. s) lexbuf }
232 | _ as c { cCode (buf @< c) lexbuf }
235 (* helper rules: comment, string, cPP {{{ *)
237 and cComment buf = parse
238 | "*/" as s { buf @. s }
239 | '\n' as c { cComment (buf @< c) (nextl lexbuf) }
240 | _ as c { cComment (buf @< c) lexbuf }
242 and cString buf = parse
243 | '"' as c { buf @< c }
244 | "\\\"" as s { cString (buf @. s) lexbuf }
245 | "\\\n" as s { cString (buf @. s) (nextl lexbuf) }
246 | [^'\n'] as c { cString (buf @< c) lexbuf }
249 | [^'\n']* "\\\n" as s { cPP (buf @. s) (nextl lexbuf) }
250 | to_eol as s { let _ = nextl lexbuf in buf @. s }
253 (* parse @type {{{ *)
255 and ext_type id typ = parse
257 | "//" to_eol { ext_type id typ lexbuf }
258 | '\n' { ext_type id typ (nextl lexbuf) }
259 | "/*" { let _ = cComment (B.create 1024) lexbuf in
260 ext_type id typ lexbuf }
261 | '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
264 let do_anch s = s, typ.fpos, lnum lexbuf in
266 | "ctype" -> {typ with ctype = do_anch s}
267 | "check" -> {typ with check = do_anch s}
268 | "push" -> {typ with push = do_anch s}
269 | "ctor" -> {typ with ctor = Some (do_anch s)}
270 | "dtor" -> {typ with dtor = Some (do_anch s)}
272 die (lnum lexbuf) typ.fpos
273 (sprintf "Unknown directive `%s'" member)
276 | '}' sp* ';' (sp* '\n' as s)?
277 { id @:= typ; startchunk cLine typ.fpos
278 (if s = None then lexbuf else nextl lexbuf) }
279 | "" { die (lnum lexbuf) typ.fpos "Syntax error" }
282 (* parse @package {{{ *)
284 and ext_pkg pkg = parse
286 | "//" to_eol { ext_pkg pkg lexbuf }
287 | '\n' { ext_pkg pkg (nextl lexbuf) }
288 | "/*" { let _ = cComment (B.create 1024) lexbuf in
290 | ("const" sp+ as const)? (ident as typ) sp+
291 (ident as member) sp* '=' sp* '{'
293 let m = {member0 with mname = member;
294 typ = const != None, type_find (lnum lexbuf)
296 let m = ext_member m pkg.file lexbuf in
297 ext_pkg {pkg with members = (m, pkg.file, lnum lexbuf)::pkg.members} lexbuf
299 | ("const" sp+ as const)? (ident as typ) sp+
300 (ident as member) sp* '=' sp* ([^';''\n']* as init)';'
302 let m = { typ = const != None,
303 type_find (lnum lexbuf) pkg.file typ;
305 init = init, pkg.file, lnum lexbuf;
306 onchange = None; }, pkg.file, lnum lexbuf in
307 ext_pkg {pkg with members = m::pkg.members} lexbuf
309 | '(' ((typdecl ',')* typdecl as ret) ')' sp*
311 '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
312 | (typdecl as ret) (ident as fname)
313 '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
315 let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
316 let args = parse_args (lnum lexbuf) pkg.file args in
317 let f, l = pkg.file, lnum lexbuf in
318 let body = ext_body pkg (B.create 1024) lexbuf in
319 let m = { rettype = rettype;
322 body = body }, f, l in
323 ext_pkg {pkg with methods = m::pkg.methods} lexbuf
325 | '}' sp* ';' (sp* '\n' as s)?
326 { Pkg({pkg with members = List.rev(pkg.members)}) :: (
327 startchunk cLine pkg.file
328 (if s = None then lexbuf else nextl lexbuf)
331 | "" { die (lnum lexbuf) pkg.file "Syntax error" }
333 and ext_body pkg buf = parse
335 | "//" to_eol as s { ext_body pkg (buf @. s) lexbuf }
336 | '\n' as c { ext_body pkg (buf @< c) lexbuf }
337 | "/*" { let buf = cComment (buf @. "/*") lexbuf in
338 ext_body pkg buf lexbuf }
339 | ';' { B.contents buf }
340 | '{' as c { let buf = ext_bodycode (buf @< c) lexbuf in
341 ext_body pkg buf lexbuf }
342 | "" { die (lnum lexbuf) pkg.file "Syntax error" }
344 and ext_bodycode buf = parse
345 | '\n' as c { ext_bodycode (buf @< c) (nextl lexbuf) }
346 | '"' as c { let buf = cString (buf @< c) lexbuf in
347 ext_bodycode buf lexbuf }
348 | "/*" as s { let buf = cComment (buf @. s) lexbuf in
349 ext_bodycode buf lexbuf }
350 | "//" to_eol as s { ext_bodycode (buf @. s) (nextl lexbuf) }
351 | "'\"'" as s { ext_bodycode (buf @. s) lexbuf }
352 | '{' as c { let buf = ext_bodycode (buf @< c) lexbuf in ext_bodycode buf lexbuf }
353 | '}' as c { buf @< c }
354 | _ as c { ext_bodycode (buf @< c) lexbuf }
357 (* parse extended member {{{ *)
359 and ext_member m f = parse
361 | "//" to_eol { ext_member m f lexbuf }
362 | '\n' { ext_member m f (nextl lexbuf) }
363 | "/*" { let _ = cComment (B.create 1024) lexbuf in
364 ext_member m f lexbuf }
365 | '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
368 let do_anch s = s, f, lnum lexbuf in
370 | "init" -> {m with init = do_anch s}
371 | "onchange" -> {m with onchange = Some(do_anch s)}
374 (sprintf "Unknown directive `%s'" member)
378 | "" { die (lnum lexbuf) f "Syntax error" }
383 (* templating functions {{{ *)
385 let upper = String.uppercase
387 Str.global_replace (Str.regexp_string "$L") "L" (
388 Str.global_replace (Str.regexp_string "$$") v tpl
391 let dump_struct_type ob begwith pkg endwith =
392 fprintf ob "%sstruct luaM_%s_t {\n" begwith pkg.name;
393 List.iter (function (m, f, l) ->
395 let ctype = t1 (snd m.typ).ctype in
396 output_string ob " ";
397 if fst m.typ then output_string ob "const ";
398 let i = try String.index ctype ':' with Not_found -> String.length ctype in
399 fprintf ob "%s %s%s;\n" (Str.string_before ctype i)
400 m.mname (Str.string_after ctype i)
402 output_endline ob ("}" ^ endwith)
405 let do_h_aux = function
408 fprintf ob "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
409 fprintf ob "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);
410 if not pkg.static then (
411 dump_struct_type ob "" pkg ";";
412 fprintf ob "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;
414 fprintf ob "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
415 fprintf ob "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
416 in List.iter do_h_aux
418 let do_func ob pkg (fn, f, l) =
419 (* return inline function *)
420 fprintf ob "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;
421 let retlen = List.fold_left (fun i t ->
424 | true, typ -> fprintf ob ", const %s luaM_x%d" (t1 typ.ctype) i; i
425 | false, typ -> fprintf ob ", %s luaM_x%d" (t1 typ.ctype) i; i
428 ignore (List.fold_left (fun i (const, typ) ->
430 let (p, f, l) = typ.push in
432 fprintf ob " %s;\n" (tplize p (sprintf "luaM_x%d" i));
436 | Some(dtor, f, l) ->
438 fprintf ob " %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))
441 fprintf ob " return %d;\n}\n" retlen;
444 fprintf ob "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
445 ignore (List.fold_left (fun i ((const, typ), name) ->
447 let ctype = t1 typ.ctype in
449 let (c, f, l) = typ.check in
451 fprintf ob " const %s %s = %s;\n" ctype name (tplize c (string_of_int i))
455 let (c, f, l) = typ.check in
457 fprintf ob " %s %s = %s;\n" ctype name (tplize c (string_of_int i))
458 | Some (ctor, f, l) ->
460 let c, f, l = typ.check in
461 tplize (sprintf "\n#line %d \"%s\"\n %s" l f c)
465 fprintf ob " %s %s = %s;\n" ctype name (tplize ctor v)
468 fprintf ob "\n#define RAISE(s) luaL_error(L, (s))\n";
469 if fn.rettype = [] then (
470 fprintf ob "#define RETURN() return luaM_ret_%s_%s(L)\n" pkg.name fn.fname
472 fprintf ob "#define RETURN(luaM_x1";
473 for i = 2 to retlen do fprintf ob ", luaM_x%d" i done;
474 fprintf ob ") \\\n return luaM_ret_%s_%s(L" pkg.name fn.fname;
475 for i = 1 to retlen do fprintf ob ", luaM_x%d" i done;
479 fprintf ob " %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body
482 let do_c_aux = function
483 | Buf (s, f, l) -> put_line ob l f; output_string ob s
485 (* dump struct const init *)
487 dump_struct_type ob "static " pkg (sprintf " %s = {\n" pkg.name)
489 fprintf ob "struct luaM_%s_t %s = {\n" pkg.name pkg.name
491 List.iter (function (m, _, _) ->
492 let (init, f, l) = m.init in
494 fprintf ob " %s,\n" (if fst m.typ then init else "0")
498 (* dump struct init func *)
499 fprintf ob "\nstatic void %s_init(void)\n{\n" pkg.name;
500 List.iter (function (m, _, _) ->
501 if not (fst m.typ) then
502 let init, f, l = m.init in
503 let field = sprintf "%s.%s" pkg.name m.mname in
505 fprintf ob " %s = %s;\n" field init;
506 match m.onchange with
509 put_line ob l f; fprintf ob " %s;\n" (tplize on field)
514 fprintf ob "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
515 fprintf ob " const char *idx = luaL_checkstring(L, 2);\n\n";
516 fprintf ob " switch (mlua_which_token(idx, -1)) {\n";
517 List.iter (function (m, _, _) ->
518 fprintf ob " case LTK_%s:\n" (upper m.mname);
519 let push, f, l = (snd m.typ).push in
521 fprintf ob " %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
522 fprintf ob " return 1;\n"
524 fprintf ob " default:\n";
525 fprintf ob " lua_rawget(L, lua_upvalueindex(1));\n";
526 fprintf ob " return 1;\n";
527 fprintf ob " }\n}\n\n";
529 (* dump __newindex *)
530 fprintf ob "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
531 fprintf ob " const char *idx = luaL_checkstring(L, 2);\n\n";
532 fprintf ob " switch (mlua_which_token(idx, -1)) {\n";
533 List.iter (function (m, _, _) ->
534 let field = sprintf "%s.%s" pkg.name m.mname in
538 fprintf ob " case LTK_%s:\n" (upper m.mname);
541 | Some (dtor, f, l) ->
543 fprintf ob " %s;\n" (tplize dtor ("&" ^ field))
547 let (c, f, l) = t.check in
549 fprintf ob " %s = %s;\n" field (tplize c "3")
550 | Some (ctor, f, l) ->
552 let c, f, l = t.check in
553 tplize (sprintf "\n#line %d \"%s\"\n %s" l f c) "3"
556 fprintf ob " %s = %s;\n" field (tplize ctor v)
558 (match m.onchange with
562 fprintf ob " %s;\n" (tplize on field)
564 fprintf ob " return 1;\n"
566 fprintf ob " default:\n";
567 fprintf ob " lua_rawset(L, lua_upvalueindex(1));\n";
568 fprintf ob " return 1;\n";
569 fprintf ob " }\n}\n";
572 List.iter (do_func ob pkg) pkg.methods;
573 fprintf ob "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;
574 List.iter (function (f, _, _) ->
575 fprintf ob " { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)
577 output_string ob (Str.global_replace (Str.regexp "%s") pkg.name
581 int luaopen_%s(lua_State *L)
583 int mt, members, methods;
587 /* create methods table, add it the the table of globals */
588 luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
589 methods = lua_gettop(L);
591 lua_newtable(L); /* for new members */
592 members = lua_gettop(L);
594 /* create metatable for %s, add it to the registry */
595 luaL_newmetatable(L, \"%s\");
598 lua_pushliteral(L, \"__index\");
599 lua_pushvalue(L, members); /* upvalue 1 */
600 lua_pushcclosure(L, &luaM_%s_index, 1);
601 lua_rawset(L, mt); /* set mt.__index */
603 lua_pushliteral(L, \"__newindex\");
604 lua_pushvalue(L, members); /* upvalue 1 */
605 lua_pushcclosure(L, &luaM_%s_newindex, 1);
606 lua_rawset(L, mt); /* set mt.__newindex */
608 lua_pushliteral(L, \"__metatable\");
609 lua_pushvalue(L, methods); /* dup methods table */
610 lua_rawset(L, mt); /* hide metatable */
612 lua_setmetatable(L, methods);
619 in List.iter do_c_aux
624 output_string stderr "usage: cpkg2c (-h | -c) file.cpkg -o output\n";
628 let warn ob = output_endline ob "/*** THIS FILE IS AUTOGENERATED !!! ***/" in
629 if Array.length Sys.argv != 5 then usage();
630 let file = Sys.argv.(2) in
631 let lexbuf = L.from_channel (open_in file) in
632 let l = (startchunk cLine file lexbuf) in
633 if Sys.argv.(3) = "-o" then
634 let ob = open_out_gen [ Open_trunc ; Open_wronly; Open_creat ] 0o444 Sys.argv.(4) in
635 match Sys.argv.(1) with
636 | "-h" -> warn ob; do_h ob l; close_out ob
637 | "-c" -> warn ob; do_c ob l; close_out ob