Skip to content

Commit d18f5d2

Browse files
y2ky2k
committed
improve reify macro: add parameter name bindings and multi-statement body support
1 parent 8d5325b commit d18f5d2

2 files changed

Lines changed: 89 additions & 25 deletions

File tree

‎macro/dune‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
(library
22
(name macro)
3-
(libraries core re unix str angstrom yojson ppx_deriving_yojson.runtime)
3+
(libraries core stage re unix str angstrom yojson ppx_deriving_yojson.runtime)
44
(preprocess
55
(pps ppx_deriving.show ppx_deriving_yojson)))

‎macro/macro_reify.ml‎

Lines changed: 88 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,24 @@
11
open Core__.Common
2+
open Stage__
23

34
(* reify macro for java_v2 backend - creates anonymous class implementing interface *)
45

56
(* Parse a method definition: (methodName [this arg1 ...] body...) *)
67
(* Metadata like ^void on method name specifies return type *)
8+
(* Returns: (return_type, method_name, args_with_types, original_arg_names, body) *)
79
let parse_method = function
810
| SList (_, SAtom (m, name) :: SList (_, _ :: _ :: args) :: body) ->
911
(* Skip first element (vector) and second element (this) *)
1012
(* m.symbol contains metadata like "void" from ^void *)
11-
(m.symbol, name, args, body)
13+
let arg_names =
14+
List.map
15+
(function SAtom (_, n) -> n | x -> failsexp __LOC__ [ x ])
16+
args
17+
in
18+
(m.symbol, name, args, arg_names, body)
1219
| SList (_, SAtom (m, name) :: SList (_, _ :: []) :: body) ->
1320
(* Only [this] - no additional args *)
14-
(m.symbol, name, [], body)
21+
(m.symbol, name, [], [], body)
1522
| x -> failsexp __LOC__ [ x ]
1623

1724
(* Generate method argument declarations *)
@@ -25,12 +32,34 @@ let generate_method_args args =
2532
| x -> failsexp __LOC__ [ x ])
2633
|> String.concat ", "
2734

35+
(* Generate let bindings to map original arg names to p0, p1, etc *)
36+
let generate_arg_bindings args arg_names body =
37+
if List.length arg_names = 0 then body
38+
else
39+
let bindings =
40+
List.concat_map
41+
(fun (i, (arg, name)) ->
42+
let typ = match arg with SAtom (m, _) -> m.symbol | _ -> "" in
43+
let meta = { meta_empty with symbol = typ } in
44+
(* Create binding pair: name p0 *)
45+
[ SAtom (meta, name); SAtom (meta_empty, Printf.sprintf "p%i" i) ])
46+
(List.mapi (fun i x -> (i, x)) (List.combine args arg_names))
47+
in
48+
(* Wrap body with let expression: (let [name1 p0 name2 p1 ...] body) *)
49+
SList
50+
( meta_empty,
51+
[
52+
SAtom (meta_empty, "let");
53+
SList (meta_empty, SAtom (meta_empty, "vector") :: bindings);
54+
body;
55+
] )
56+
2857
let invoke simplify = function
2958
| SList (_, SAtom (_, "reify") :: SAtom (_, interface) :: methods) ->
3059
let parsed = List.map parse_method methods in
3160
let method_codes =
3261
parsed
33-
|> List.map (fun (annot, name, args, body) ->
62+
|> List.map (fun (annot, name, args, arg_names, body) ->
3463
let ret_type = if annot = "" then "Object" else annot in
3564
let args_decl = generate_method_args args in
3665
(* For simplest version, just use the body directly *)
@@ -39,7 +68,13 @@ let invoke simplify = function
3968
| [ single ] -> single
4069
| _ -> SList (meta_empty, SAtom (meta_empty, "do") :: body)
4170
in
42-
let simplified_body = simplify body_expr in
71+
(* Wrap body with let bindings for parameter name mapping *)
72+
let body_with_bindings =
73+
generate_arg_bindings args arg_names body_expr
74+
in
75+
let simplified_body = simplify body_with_bindings in
76+
(* Flatten nested do* blocks so butlast/last work correctly *)
77+
let flat_body = Stage_flat_do.invoke simplified_body in
4378
(* Build method code using __compiler_emit *)
4479
(* Handle void vs non-void return types *)
4580
(* Use try-catch to handle exceptions without requiring throws clause *)
@@ -52,7 +87,7 @@ let invoke simplify = function
5287
(Printf.sprintf
5388
"\n @Override public void %s(%s) {\n try {\n "
5489
name args_decl);
55-
simplified_body;
90+
flat_body;
5691
pack_string
5792
";\n\
5893
\ } catch (Exception e) {\n\
@@ -61,25 +96,54 @@ let invoke simplify = function
6196
\ }";
6297
] )
6398
else
64-
SList
65-
( meta_empty,
66-
[
67-
SAtom (meta_empty, "__compiler_emit");
68-
pack_string
69-
(Printf.sprintf
70-
"\n\
71-
\ @Override public %s %s(%s) {\n\
72-
\ try {\n\
73-
\ return ("
74-
ret_type name args_decl);
75-
simplified_body;
76-
pack_string
77-
");\n\
78-
\ } catch (Exception e) {\n\
79-
\ throw new RuntimeException(e);\n\
80-
\ }\n\
81-
\ }";
82-
] ))
99+
(* For non-void return: emit statements first, then return last expression *)
100+
let butlast = SexpUtil.butlast flat_body in
101+
let last_expr = SexpUtil.last flat_body in
102+
if List.length butlast = 0 then
103+
(* Simple case: just one expression *)
104+
SList
105+
( meta_empty,
106+
[
107+
SAtom (meta_empty, "__compiler_emit");
108+
pack_string
109+
(Printf.sprintf
110+
"\n\
111+
\ @Override public %s %s(%s) {\n\
112+
\ try {\n\
113+
\ return (%s)("
114+
ret_type name args_decl ret_type);
115+
flat_body;
116+
pack_string
117+
");\n\
118+
\ } catch (Exception e) {\n\
119+
\ throw new RuntimeException(e);\n\
120+
\ }\n\
121+
\ }";
122+
] )
123+
else
124+
(* Multiple statements: emit all but last, then return last *)
125+
let statements =
126+
SList (meta_empty, SAtom (meta_empty, "do*") :: butlast)
127+
in
128+
SList
129+
( meta_empty,
130+
[
131+
SAtom (meta_empty, "__compiler_emit");
132+
pack_string
133+
(Printf.sprintf
134+
"\n @Override public %s %s(%s) {\n try {\n "
135+
ret_type name args_decl);
136+
statements;
137+
pack_string ";\n return (";
138+
pack_string (ret_type ^ ")(");
139+
last_expr;
140+
pack_string
141+
");\n\
142+
\ } catch (Exception e) {\n\
143+
\ throw new RuntimeException(e);\n\
144+
\ }\n\
145+
\ }";
146+
] ))
83147
in
84148
(* Build the anonymous class *)
85149
(* Convert $ to . for inner classes (e.g., Thread$UncaughtExceptionHandler -> Thread.UncaughtExceptionHandler) *)

0 commit comments

Comments
 (0)