Skip to content
Browse files

more progress on lambda meta generator

git-svn-id: http://ocamljs.googlecode.com/svn/trunk@189 27578800-e353-0410-a23a-a7c9f63c6ccd
  • Loading branch information...
1 parent 30af97c commit cb2fa9e26bcf364877b6014d8eee6609c1d124a2 Jake Donham committed
Showing with 107 additions and 100 deletions.
  1. +47 −57 src/jscomp/jsgen.ml
  2. +5 −0 src/jslib/jslib_ast.ml
  3. +47 −43 src/jslib/lambda_meta_generator.ml
  4. +8 −0 src/jslib/syntax_lambda.ml
View
104 src/jscomp/jsgen.ml
@@ -579,85 +579,75 @@ and comp_letrecs_st tail expr k =
| e -> comp_expr_st tail e k in
cl expr
-(* XXX annoying, would be nice to Camlp4-generate this *)
and inline_exp = function
(* XXX actually we never get these because of the _loc arg *)
| Lconst (Const_block _) as cb -> inline_exp (makeblock_of_const cb)
| <:lam_exp< this >> -> <:exp< this >>
| <:lam_exp< $id:v$ >> -> <:exp< $id:inline_string v$ >>
| <:lam_exp< [ $el$ ] >> -> <:exp< [ $inline_exp el$ ] >>
- | Lprim (Pmakeblock (3, _), [_; kvl]) -> Jobject (_loc, inline_list (inline_pair inline_exp inline_exp) kvl)
+ | <:lam_aexp< Jobject (_loc, $kvl$) >> -> Jobject (_loc, inline_list (inline_pair inline_exp inline_exp) kvl)
(*
| <:lam_exp< $str:s$ >> -> <:exp< $str:s$ >>
-*) (* XXX bools don't work in lambda_meta_generator *)
- | Lprim (Pmakeblock (4, _), [_; s; qq]) -> Jstring (_loc, inline_string s, inline_bool qq) (* XXX the quote flag is not accessible from quotation *)
+*) (* quote flag is not accessible *)
+ | <:lam_aexp< Jstring (_loc, $s$, $qq$) >> -> Jstring (_loc, inline_string s, inline_bool qq)
| <:lam_exp< $flo:s$ >> -> <:exp< $flo:inline_string s$ >> (* XXX :num ? *)
| <:lam_exp< null >> -> <:exp< null >>
-(*
- | <:lam_exp< true >> -> <:exp< true >> (* XXX :bool *)
- | <:lam_exp< false >> -> <:exp< false >>
-*) (* XXX bools don't work in lambda_meta_generator *)
- | Lprim (Pmakeblock (7, _), [_; b]) -> Jbool (_loc, inline_bool b)
- | Lprim (Pmakeblock (8, _), [_; so; sl; stl]) ->
+ | <:lam_aexp< Jbool (_loc, $b$) >> -> Jbool (_loc, inline_bool b) (* XXX :bool ? *)
+ | <:lam_aexp< Jfun (_loc, $so$, $sl$, $stl$) >> ->
Jfun (_loc,
inline_option inline_string so,
inline_list inline_string sl,
inline_list inline_stmt stl)
| <:lam_exp< $e$.$s$ >> -> <:exp< $inline_exp e$.$inline_string s$ >>
- | Lprim (Pmakeblock (10, _), [_; u; e]) -> Junop (_loc, inline_unop u, inline_exp e)
- | Lprim (Pmakeblock (11, _), [_; b; e1; e2]) -> Jbinop (_loc, inline_binop b, inline_exp e1, inline_exp e2)
+ | <:lam_aexp< Junop (_loc, $u$, $e$) >> -> Junop (_loc, inline_unop u, inline_exp e)
+ | <:lam_aexp< Jbinop (_loc, $b$, $e1$, $e2$) >> -> Jbinop (_loc, inline_binop b, inline_exp e1, inline_exp e2)
| <:lam_exp< $i$ ? $t$ : $e$ >> -> <:exp< $inline_exp i$ ? $inline_exp t$ : $inline_exp e$ >>
| <:lam_exp< $e$($el$) >> -> <:exp< $inline_exp e$($inline_exp el$) >>
- | Lprim (Pmakeblock (14, _), [_; e; elo]) -> Jnew (_loc, inline_exp e, inline_option inline_exp elo)
- | Lprim (Pmakeblock (15, _), [_]) -> Jexp_nil _loc
- | Lprim (Pmakeblock (16, _), [_; e1; e2]) -> Jexp_cons (_loc, inline_exp e1, inline_exp e2)
+ | <:lam_aexp< Jnew (_loc, $e$, $elo$) >> -> Jnew (_loc, inline_exp e, inline_option inline_exp elo)
+ | <:lam_aexp< Jexp_nil _loc >> -> Jexp_nil _loc
+ | <:lam_aexp< Jexp_cons (_loc, $e1$, $e2$) >> -> Jexp_cons (_loc, inline_exp e1, inline_exp e2)
| Lprim (Pccall { prim_name = "$inline_antiexp" }, [e]) -> comp_expr false e
| _ -> raise (Failure "bad inline exp")
and inline_stmt = function
| Lconst (Const_block _) as cb -> inline_stmt (makeblock_of_const cb)
- | Lprim (Pmakeblock (tag, _), args) ->
- begin
- match tag, args with
- | 0, [_] -> Jempty _loc
- | 1, [_; seol] ->
- Jvars (_loc, inline_list (inline_pair inline_string (inline_option inline_exp)) seol)
- | 2, [_; s; sl; stl] ->
- Jfuns (_loc, inline_string s, inline_list inline_string sl, inline_list inline_stmt stl)
- | 3, [_; eo] -> Jreturn (_loc, inline_option inline_exp eo)
- | 4, [_; so] -> Jcontinue (_loc, inline_option inline_string so)
- | 5, [_; so] -> Jbreak (_loc, inline_option inline_string so)
- | 6, [_; e; esll; slo] ->
- Jswitch (_loc,
- inline_exp e,
- inline_list (inline_pair inline_exp (inline_list inline_stmt)) esll,
- inline_option (inline_list inline_stmt) slo)
- | 7, [_; e; s; so] -> Jites (_loc, inline_exp e, inline_stmt s, inline_option inline_stmt so)
- | 8, [_; e] -> Jthrow (_loc, inline_exp e)
- | 9, [_; e] -> Jexps (_loc, inline_exp e)
- | 10, [_; sl1; s; sl2] ->
- Jtrycatch (_loc, inline_list inline_stmt sl1, inline_string s, inline_list inline_stmt sl2)
- | 11, [_; sl1; sl2] ->
- Jtryfinally (_loc, inline_list inline_stmt sl1, inline_list inline_stmt sl2)
- | 12, [_; sl1; s; sl2; sl3] ->
- Jtrycatchfinally (_loc,
- inline_list inline_stmt sl1,
- inline_string s,
- inline_list inline_stmt sl2,
- inline_list inline_stmt sl3)
- | 13, [_; eo1; eo2; eo3; s] ->
- Jfor (_loc,
- inline_option inline_exp eo1,
- inline_option inline_exp eo2,
- inline_option inline_exp eo3,
- inline_stmt s)
- | 14, [_; s; e] -> Jdowhile (_loc, inline_stmt s, inline_exp e)
- | 15, [_; e; s] -> Jwhile (_loc, inline_exp e, inline_stmt s)
- | 16, [_; sl] -> Jblock (_loc, inline_list inline_stmt sl)
- | 17, [_; e; s] -> Jwith (_loc, inline_exp e, inline_stmt s)
- | 18, [_; s; st] -> Jlabel (_loc, inline_string s, inline_stmt st)
- | _ -> raise (Failure "bad inline stmt")
- end
+ | <:lam_astmt< Jempty _loc >> -> Jempty _loc
+ | <:lam_astmt< Jvars (_loc, $seol$) >> ->
+ Jvars (_loc, inline_list (inline_pair inline_string (inline_option inline_exp)) seol)
+ | <:lam_astmt< Jfuns (_loc, $s$, $sl$, $stl$) >> ->
+ Jfuns (_loc, inline_string s, inline_list inline_string sl, inline_list inline_stmt stl)
+ | <:lam_astmt< Jreturn (_loc, $eo$) >> -> Jreturn (_loc, inline_option inline_exp eo)
+ | <:lam_astmt< Jcontinue (_loc, $so$) >> -> Jcontinue (_loc, inline_option inline_string so)
+ | <:lam_astmt< Jbreak (_loc, $so$) >> -> Jbreak (_loc, inline_option inline_string so)
+ | <:lam_astmt< Jswitch (_loc, $e$, $esll$, $slo$) >> ->
+ Jswitch (_loc,
+ inline_exp e,
+ inline_list (inline_pair inline_exp (inline_list inline_stmt)) esll,
+ inline_option (inline_list inline_stmt) slo)
+ | <:lam_astmt< Jites (_loc, $e$, $s$, $so$) >> -> Jites (_loc, inline_exp e, inline_stmt s, inline_option inline_stmt so)
+ | <:lam_astmt< Jthrow (_loc, $e$) >> -> Jthrow (_loc, inline_exp e)
+ | <:lam_astmt< Jexps (_loc, $e$) >> -> Jexps (_loc, inline_exp e)
+ | <:lam_astmt< Jtrycatch (_loc, $sl1$, $s$, $sl2$) >> ->
+ Jtrycatch (_loc, inline_list inline_stmt sl1, inline_string s, inline_list inline_stmt sl2)
+ | <:lam_astmt< Jtryfinally (_loc, $sl1$, $sl2$) >> ->
+ Jtryfinally (_loc, inline_list inline_stmt sl1, inline_list inline_stmt sl2)
+ | <:lam_astmt< Jtrycatchfinally (_loc, $sl1$, $s$, $sl2$, $sl3$) >> ->
+ Jtrycatchfinally (_loc,
+ inline_list inline_stmt sl1,
+ inline_string s,
+ inline_list inline_stmt sl2,
+ inline_list inline_stmt sl3)
+ | <:lam_astmt< Jfor (_loc, $eo1$, $eo2$, $eo3$, $s$) >> ->
+ Jfor (_loc,
+ inline_option inline_exp eo1,
+ inline_option inline_exp eo2,
+ inline_option inline_exp eo3,
+ inline_stmt s)
+ | <:lam_astmt< Jdowhile (_loc, $s$, $e$) >> -> Jdowhile (_loc, inline_stmt s, inline_exp e)
+ | <:lam_astmt< Jwhile (_loc, $e$, $s$) >> -> Jwhile (_loc, inline_exp e, inline_stmt s)
+ | <:lam_astmt< Jblock (_loc, $sl$) >> -> Jblock (_loc, inline_list inline_stmt sl)
+ | <:lam_astmt< Jwith (_loc, $e$, $s$) >> -> Jwith (_loc, inline_exp e, inline_stmt s)
+ | <:lam_astmt< Jlabel (_loc, $s$, $st$) >> -> Jlabel (_loc, inline_string s, inline_stmt st)
(*| Lprim (Pccall { prim_name = "$inline_antistmt" }, [s]) -> *)(* XXX *)
| _ -> raise (Failure "bad inline stmt")
View
5 src/jslib/jslib_ast.ml
@@ -144,6 +144,7 @@ struct
struct
let meta_loc _loc _ =
(* XXX translate the argument location *)
+ (* XXX or at least support ExAnt? *)
<:expr<
Lambda.Lconst
(Lambda.Const_block (0, [
@@ -165,6 +166,8 @@ struct
let meta_option mf_a _loc = function
| <:expr< None >> -> <:expr< None >>
| <:expr< Some $a$ >> -> <:expr< Some $mf_a _loc a$ >>
+ | Ast.ExAnt (_loc, s) -> Ast.ExAnt (_loc, s)
+ | _ -> invalid_arg "meta_option"
include LambdaAbstractMetaGeneratorExpr(Jslib_ast)
end
@@ -176,6 +179,8 @@ struct
let meta_option mf_a _loc = function
| <:expr< None >> -> <:patt< None >>
| <:expr< Some $a$ >> -> <:patt< Some $mf_a _loc a$ >>
+ | Ast.ExAnt (_loc, s) -> Ast.PaAnt (_loc, s)
+ | _ -> invalid_arg "meta_option"
include LambdaAbstractMetaGeneratorPatt(Jslib_ast)
end
View
90 src/jslib/lambda_meta_generator.ml
@@ -211,7 +211,7 @@ let mk_meta m =
end <:binding<>>
let mk_abs_meta m =
- let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in
+ let m_name_uid x = <:ident< $uid:x$ >> in
fold_type_decls m begin fun tyname tydcl binding_acc ->
match tydcl with
| Ast.TyDcl (_, _, tyvars, Ast.TySum (_, ty), _) ->
@@ -223,49 +223,45 @@ let mk_abs_meta m =
<:patt< Ast.ExApp(_, $acc$, $id:x i$) >>
end (pm_id m (pmeta_ident m m_name_cons)) in
let e =
-(*
- if cons = "BAnt" || cons = "OAnt" || cons = "LAnt" then
- <:expr< $id:m.ant$ _loc x0 >>
- else if is_antiquot_data_ctor cons then
- expr_of_data_ctor_decl m.ant tyargs
- else
-*)
- let tag = <:expr< $m.int$ _loc $str:string_of_int tag$ >> in
- let args =
- fold_right_args tyargs begin fun ty i acc ->
- let rec fcall_of_ctyp ty =
- match ty with
- | <:ctyp< $id:id$ >> ->
- <:expr< $id:meta_ (string_of_ident id)$ >>
- | <:ctyp< ($t1$ * $t2$) >> ->
- <:expr< fun _loc -> function
- | Ast.ExTup (_, Ast.ExCom (_, x1, x2)) ->
- $m.tup$ _loc
- ($m.com$ _loc
- ($fcall_of_ctyp t1$ _loc x1)
- ($fcall_of_ctyp t2$ _loc x2))
- | _ -> invalid_arg "tuple"
- >>
- | <:ctyp< $t2$ $t1$ >> ->
- <:expr< $fcall_of_ctyp t1$ $fcall_of_ctyp t2$ >>
- | <:ctyp< '$s$ >> -> <:expr< $lid:mf_ s$ >>
- | _ -> failure in
- m_app m
- (m_app m (m_uid m "::")
- <:expr< $fcall_of_ctyp ty$ _loc $id:x i$ >>)
- acc
- end (m_uid m "[]") in
- m_app m
- (m_app m
- (m_id m (meta_ident m <:ident< Lambda.Lprim >>))
- (m_app m
- (m_app m
- (m_id m (meta_ident m <:ident< Lambda.Pmakeblock >>))
- tag)
- (m_id m (meta_ident m <:ident< Asttypes.Immutable >>))))
- args
+ let tag = <:expr< $m.int$ _loc $str:string_of_int tag$ >> in
+ let args =
+ fold_right_args tyargs begin fun ty i acc ->
+ let rec fcall_of_ctyp ty =
+ match ty with
+ | <:ctyp< $id:id$ >> ->
+ <:expr< $id:meta_ (string_of_ident id)$ >>
+ | <:ctyp< ($t1$ * $t2$) >> ->
+ <:expr< fun _loc -> function
+ | Ast.ExTup (_, Ast.ExCom (_, x1, x2)) ->
+ $m.tup$ _loc
+ ($m.com$ _loc
+ ($fcall_of_ctyp t1$ _loc x1)
+ ($fcall_of_ctyp t2$ _loc x2))
+ | _ -> invalid_arg "tuple"
+ >>
+ | <:ctyp< $t2$ $t1$ >> ->
+ <:expr< $fcall_of_ctyp t1$ $fcall_of_ctyp t2$ >>
+ | <:ctyp< '$s$ >> -> <:expr< $lid:mf_ s$ >>
+ | _ -> failure in
+ m_app m
+ (m_app m (m_uid m "::")
+ <:expr< $fcall_of_ctyp ty$ _loc $id:x i$ >>)
+ acc
+ end (m_uid m "[]") in
+ m_app m
+ (m_app m
+ (m_id m (meta_ident m <:ident< Lambda.Lprim >>))
+ (m_app m
+ (m_app m
+ (m_id m (meta_ident m <:ident< Lambda.Pmakeblock >>))
+ tag)
+ (m_id m (meta_ident m <:ident< Asttypes.Immutable >>))))
+ args
in <:match_case< $p$ -> $e$ | $acc$ >>
- end <:match_case<>> in
+ end <:match_case<
+ Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
+ | _ -> invalid_arg $`str:"meta_" ^ tyname$
+ >> in
let funct =
List.fold_right begin fun tyvar acc ->
match tyvar with
@@ -321,15 +317,19 @@ let filter st =
struct
let meta_string _loc = function
| Ast.ExStr (_loc, s) -> $m.str$ _loc s
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
| _ -> invalid_arg "meta_string"
let meta_int _loc = function
| Ast.ExInt (loc, s) -> $m.int$ _loc s
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
| _ -> invalid_arg "meta_int"
let meta_float _loc = function
| Ast.ExFlo (_loc, s) -> $m.flo$ _loc s
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
| _ -> invalid_arg "meta_float"
let meta_char _loc = function
| Ast.ExChr (_loc, s) -> $m.chr$ _loc s
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
| _ -> invalid_arg "meta_char"
(*
let meta_bool _loc b =
@@ -340,9 +340,13 @@ let filter st =
let meta_bool _loc = function
| <:expr< false >> -> $m_uid m "False"$
| <:expr< true >> -> $m_uid m "True"$
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
+ | _ -> invalid_arg "meta_bool"
let rec meta_list mf_a _loc = function
| <:expr< [] >> -> $m_uid m "[]"$
| <:expr< $x$ :: $xs$ >> -> $m_app m (m_app m (m_uid m "::") <:expr< mf_a _loc x >>) <:expr< meta_list mf_a _loc xs >>$
+ | Ast.ExAnt (_loc, s) -> $id:m.ant$ (_loc, s)
+ | _ -> invalid_arg "meta_list"
let rec $bi$
end >> in
match super#module_expr me with
View
8 src/jslib/syntax_lambda.ml
@@ -163,7 +163,15 @@ let add_ocaml_quotation name entry mexpr mpatt =
Q.add name Q.DynAst.str_item_tag expand_str_item
;;
+(*
+ these quotations match / produce the lambda term to which a
+ Jslib_ast value compiles. lam_{exp,...} take concrete syntax,
+ lam_{aexp,...} take abstract syntax. see jscomp/jsgen.ml for
+ examples.
+*)
add_js_quotation "lam_exp" Jslib_parse.expression ME.meta_exp MP.meta_exp;
add_js_quotation "lam_stmt" Jslib_parse.statement ME.meta_stmt MP.meta_stmt;
add_ocaml_quotation "lam_aexp" Syntax.expr MAE.meta_exp MAP.meta_exp;
add_ocaml_quotation "lam_astmt" Syntax.expr MAE.meta_stmt MAP.meta_stmt;
+add_ocaml_quotation "lam_unop" Syntax.expr MAE.meta_unop MAP.meta_unop;
+add_ocaml_quotation "lam_binop" Syntax.expr MAE.meta_binop MAP.meta_binop;

0 comments on commit cb2fa9e

Please sign in to comment.
Something went wrong with that request. Please try again.