Permalink
Browse files

checkpoint lambda meta generator stuff

git-svn-id: http://ocamljs.googlecode.com/svn/trunk@188 27578800-e353-0410-a23a-a7c9f63c6ccd
  • Loading branch information...
1 parent 98879ca commit 30af97c3a36faf427a704c88a52efea3f04ec6d2 Jake Donham committed Jun 22, 2009
View
2 src/jscomp/_tags
@@ -2,7 +2,7 @@
<emitjs.mli>: pkg_jslib
<emitjs.ml>: pkg_jslib
<jsgen.mli>: pkg_jslib
-<jsgen.ml>: syntax_camlp4o,pkg_jslib.quotations
+<jsgen.ml>: syntax_camlp4o,pkg_jslib.quotations,pkg_jslib.lambda
<jscompile.ml>: pkg_jslib
<jslink.ml>: pkg_jslib
View
54 src/jscomp/jsgen.ml
@@ -583,32 +583,34 @@ and comp_letrecs_st tail expr k =
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)
- | Lprim (Pmakeblock (tag, _), args) ->
- begin
- match tag, args with
- | 0, [_] -> Jthis _loc
- | 1, [_; v] -> Jvar (_loc, inline_string v)
- | 2, [_; el] -> Jarray (_loc, inline_exp el)
- | 3, [_; kvl] -> Jobject (_loc, inline_list (inline_pair inline_exp inline_exp) kvl)
- | 4, [_; s; qq] -> Jstring (_loc, inline_string s, inline_bool qq)
- | 5, [_; s] -> Jnum (_loc, inline_string s)
- | 6, [_] -> Jnull _loc
- | 7, [_; b] -> Jbool (_loc, inline_bool b)
- | 8, [_; so; sl; stl] ->
- Jfun (_loc,
- inline_option inline_string so,
- inline_list inline_string sl,
- inline_list inline_stmt stl)
- | 9, [_; e; s] -> Jfieldref (_loc, inline_exp e, inline_string s)
- | 10, [_; u; e] -> Junop (_loc, inline_unop u, inline_exp e)
- | 11, [_; b; e1; e2] -> Jbinop (_loc, inline_binop b, inline_exp e1, inline_exp e2)
- | 12, [_; i; t; e] -> Jite (_loc, inline_exp i, inline_exp t, inline_exp e)
- | 13, [_; e; el] -> Jcall (_loc, inline_exp e, inline_exp el)
- | 14, [_; e; elo] -> Jnew (_loc, inline_exp e, inline_option inline_exp elo)
- | 15, [_] -> Jexp_nil _loc
- | 16, [_; e1; e2] -> Jexp_cons (_loc, inline_exp e1, inline_exp e2)
- | _ -> raise (Failure "bad inline exp")
- end
+ | <: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_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 *)
+ | <: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]) ->
+ 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_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)
| Lprim (Pccall { prim_name = "$inline_antiexp" }, [e]) -> comp_expr false e
| _ -> raise (Failure "bad inline exp")
View
6 src/jslib/META
@@ -18,3 +18,9 @@ package "inline" (
requires(syntax,preprocessor) = "ulex"
archive(syntax,preprocessor) = "ulexing.cma,jslib.cma,syntax_inline.cmo"
)
+
+package "lambda" (
+ description = "Syntax extension: quotations to create lambda nodes"
+ requires(syntax,preprocessor) = "ulex"
+ archive(syntax,preprocessor) = "ulexing.cma,jslib.cma,syntax_lambda.cmo"
+)
View
3 src/jslib/Makefile
@@ -4,6 +4,7 @@ FILES=\
jslib.cma jslib.cmxa jslib.a \
syntax_quotations.cmo \
syntax_inline.cmo \
+syntax_lambda.cmo \
jslib_ast.mli jslib_ast.cmi \
jslib_parse.mli jslib_parse.cmi \
jslib_pp.mli jslib_pp.cmi \
@@ -13,7 +14,7 @@ BFILES=$(addprefix _build/,$(FILES))
all: myocamlbuild.ml
OCAMLFIND_IGNORE_DUPS_IN=$(LIBDIR)/site-lib \
OCAMLPATH=`pwd`/../../stage \
- ocamlbuild jslib.cma jslib.cmxa syntax_quotations.cmo syntax_inline.cmo
+ ocamlbuild -verbose 10 jslib.cma jslib.cmxa syntax_quotations.cmo syntax_inline.cmo syntax_lambda.cmo
ocamlfind remove -destdir ../../stage jslib
ocamlfind install -destdir ../../stage jslib META $(BFILES)
View
4 src/jslib/_tags
@@ -1,5 +1,7 @@
<jslib_lexer.ml*>: syntax_camlp4o,pkg_camlp4,pkg_ulex
<jslib_parse.ml*>: syntax_camlp4o,pkg_camlp4,pkg_camlp4.extend
-<jslib_ast.ml*> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.foldgenerator,pkg_camlp4.metagenerator,pkg_camlp4.macro
+<lambda_meta_generator.ml> : syntax_camlp4o,pkg_camlp4.macro,pkg_camlp4.quotations.o
+<jslib_ast.ml*> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.foldgenerator,pkg_camlp4.metagenerator,lambda_meta_generator,pkg_camlp4.macro
<syntax_quotations.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
<syntax_inline.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
+<syntax_lambda.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
View
71 src/jslib/jslib_ast.ml
@@ -109,4 +109,75 @@ struct
end
end
+ module MakeLambda (MetaLoc : META_LOC) =
+ struct
+ open MetaLoc
+
+ module Expr =
+ struct
+ let meta_loc = meta_loc_expr
+
+ let meta_option mf_a _loc = function
+ | None -> <:expr< None >>
+ | Some a -> <:expr< Some $mf_a _loc a$ >>
+
+ include LambdaMetaGeneratorExpr(Jslib_ast)
+ end
+
+ module Patt =
+ struct
+ let meta_loc = meta_loc_patt
+
+ let meta_option mf_a _loc = function
+ | None -> <:patt< None >>
+ | Some a -> <:patt< Some $mf_a _loc a$ >>
+
+ include LambdaMetaGeneratorPatt(Jslib_ast)
+ end
+ end
+
+ module MakeAbstractLambda (MetaLoc : META_LOC) =
+ struct
+ open MetaLoc
+
+ module Expr =
+ struct
+ let meta_loc _loc _ =
+ (* XXX translate the argument location *)
+ <:expr<
+ Lambda.Lconst
+ (Lambda.Const_block (0, [
+ Lambda.Const_immstring "ghost-location";
+ Lambda.Const_block (0, [
+ Lambda.Const_base (Asttypes.Const_int 1);
+ Lambda.Const_base (Asttypes.Const_int 0);
+ Lambda.Const_base (Asttypes.Const_int 0);
+ ]);
+ Lambda.Const_block (0, [
+ Lambda.Const_base (Asttypes.Const_int 1);
+ Lambda.Const_base (Asttypes.Const_int 0);
+ Lambda.Const_base (Asttypes.Const_int 0);
+ ]);
+ Lambda.Const_pointer 1;
+ ]))
+ >>
+
+ let meta_option mf_a _loc = function
+ | <:expr< None >> -> <:expr< None >>
+ | <:expr< Some $a$ >> -> <:expr< Some $mf_a _loc a$ >>
+
+ include LambdaAbstractMetaGeneratorExpr(Jslib_ast)
+ end
+
+ module Patt =
+ struct
+ let meta_loc _loc _ = <:patt< _ >>
+
+ let meta_option mf_a _loc = function
+ | <:expr< None >> -> <:patt< None >>
+ | <:expr< Some $a$ >> -> <:patt< Some $mf_a _loc a$ >>
+
+ include LambdaAbstractMetaGeneratorPatt(Jslib_ast)
+ end
+ end
end
View
152 src/jslib/jslib_ast.mli
@@ -60,6 +60,7 @@ module Meta :
val meta_loc_expr :
Camlp4.PreCast.Ast.loc -> 'a -> Camlp4.PreCast.Ast.expr
end
+
module Make :
functor (MetaLoc : META_LOC) ->
sig
@@ -134,4 +135,155 @@ module Meta :
unop -> Camlp4.PreCast.Ast.patt
end
end
+
+ module MakeLambda :
+ functor (MetaLoc : META_LOC) ->
+ sig
+ module Expr :
+ sig
+ val meta_loc :
+ Camlp4.PreCast.Loc.t ->
+ Camlp4.PreCast.Loc.t -> Camlp4.PreCast.Ast.expr
+ val meta_option :
+ (Camlp4.PreCast.Ast.loc -> 'a -> Camlp4.PreCast.Ast.expr) ->
+ Camlp4.PreCast.Ast.loc ->
+ 'a option -> Camlp4.PreCast.Ast.expr
+ val meta_string :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.expr
+ val meta_int :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.expr
+ val meta_float :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.expr
+ val meta_char :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.expr
+ val meta_bool :
+ Camlp4.PreCast.Ast.loc -> bool -> Camlp4.PreCast.Ast.expr
+ val meta_list :
+ (Camlp4.PreCast.Ast.loc -> 'a -> Camlp4.PreCast.Ast.expr) ->
+ Camlp4.PreCast.Ast.loc -> 'a list -> Camlp4.PreCast.Ast.expr
+ val meta_binop :
+ Camlp4.PreCast.Ast.loc ->
+ binop -> Camlp4.PreCast.Ast.expr
+ val meta_exp :
+ Camlp4.PreCast.Ast.loc ->
+ exp -> Camlp4.PreCast.Ast.expr
+ val meta_stmt :
+ Camlp4.PreCast.Ast.loc ->
+ stmt -> Camlp4.PreCast.Ast.expr
+ val meta_unop :
+ Camlp4.PreCast.Ast.loc ->
+ unop -> Camlp4.PreCast.Ast.expr
+ end
+ module Patt :
+ sig
+ val meta_loc :
+ Camlp4.PreCast.Loc.t ->
+ Camlp4.PreCast.Loc.t -> Camlp4.PreCast.Ast.patt
+ val meta_option :
+ (Camlp4.PreCast.Ast.loc -> 'a -> Camlp4.PreCast.Ast.patt) ->
+ Camlp4.PreCast.Ast.loc ->
+ 'a option -> Camlp4.PreCast.Ast.patt
+ val meta_string :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.patt
+ val meta_int :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.patt
+ val meta_float :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.patt
+ val meta_char :
+ Camlp4.PreCast.Ast.loc -> string -> Camlp4.PreCast.Ast.patt
+ val meta_bool :
+ Camlp4.PreCast.Ast.loc -> bool -> Camlp4.PreCast.Ast.patt
+ val meta_list :
+ (Camlp4.PreCast.Ast.loc -> 'a -> Camlp4.PreCast.Ast.patt) ->
+ Camlp4.PreCast.Ast.loc -> 'a list -> Camlp4.PreCast.Ast.patt
+ val meta_binop :
+ Camlp4.PreCast.Ast.loc ->
+ binop -> Camlp4.PreCast.Ast.patt
+ val meta_exp :
+ Camlp4.PreCast.Ast.loc ->
+ exp -> Camlp4.PreCast.Ast.patt
+ val meta_stmt :
+ Camlp4.PreCast.Ast.loc ->
+ stmt -> Camlp4.PreCast.Ast.patt
+ val meta_unop :
+ Camlp4.PreCast.Ast.loc ->
+ unop -> Camlp4.PreCast.Ast.patt
+ end
+ end
+
+ module MakeAbstractLambda :
+ functor (MetaLoc : META_LOC) ->
+ sig
+ module Expr :
+ sig
+ val meta_loc :
+ Camlp4.PreCast.Loc.t ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_option :
+ (Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr) ->
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_string :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_int :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_float :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_char :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_bool :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_list :
+ (Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr) ->
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_binop :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_exp :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_stmt :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ val meta_unop :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.expr
+ end
+ module Patt :
+ sig
+ val meta_loc :
+ Camlp4.PreCast.Loc.t ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_option :
+ (Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt) ->
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_string :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_int :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_float :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_char :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_bool :
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_list :
+ (Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt) ->
+ Camlp4.PreCast.Ast.loc -> Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_binop :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_exp :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_stmt :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ val meta_unop :
+ Camlp4.PreCast.Ast.loc ->
+ Camlp4.PreCast.Ast.expr -> Camlp4.PreCast.Ast.patt
+ end
+ end
+
end
View
362 src/jslib/lambda_meta_generator.ml
@@ -0,0 +1,362 @@
+(*
+ * This file is part of ocamljs, OCaml to Javascript compiler
+ * Copyright (C) 2007-9 Skydeck, Inc
+ * Original file (camlp4/Camlp4Filters/Camlp4MetaGenerator.ml in
+ * the Objective Caml source distribution) is Copyright (C) INRIA.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the Free
+ * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA
+ *)
+
+open Camlp4
+open PreCast
+module MapTy = Map.Make(String)
+
+let _loc = Loc.ghost
+
+type t =
+ { name : Ast.ident;
+ type_decls : Ast.ctyp MapTy.t;
+ acc : Ast.expr;
+ app : Ast.expr;
+ id : Ast.expr;
+ tup : Ast.expr;
+ com : Ast.expr;
+ str : Ast.expr;
+ int : Ast.expr;
+ flo : Ast.expr;
+ chr : Ast.expr;
+ ant : Ast.ident;
+ }
+
+let ex_t i type_decls = {
+ name = i;
+ type_decls = Lazy.force type_decls;
+ app = <:expr< Ast.ExApp >>;
+ acc = <:expr< Ast.ExAcc >>;
+ id = <:expr< Ast.ExId >>;
+ tup = <:expr< Ast.ExTup >>;
+ com = <:expr< Ast.ExCom >>;
+ str = <:expr< Ast.ExStr >>;
+ int = <:expr< Ast.ExInt >>;
+ flo = <:expr< Ast.ExFlo >>;
+ chr = <:expr< Ast.ExChr >>;
+ ant = <:ident< Ast.ExAnt >>
+}
+
+let pa_t i type_decls = {
+ name = i;
+ type_decls = Lazy.force type_decls;
+ app = <:expr< Ast.PaApp >>;
+ acc = <:expr< Ast.PaAcc >>;
+ id = <:expr< Ast.PaId >>;
+ tup = <:expr< Ast.PaTup >>;
+ com = <:expr< Ast.PaCom >>;
+ str = <:expr< Ast.PaStr >>;
+ int = <:expr< Ast.PaInt >>;
+ flo = <:expr< Ast.PaFlo >>;
+ chr = <:expr< Ast.PaChr >>;
+ ant = <:ident< Ast.PaAnt >>
+}
+
+let x i = <:ident< $lid:"x"^string_of_int i$ >>
+
+let meta_ s = <:ident< $lid:"meta_"^s$ >>
+
+let mf_ s = "mf_" ^ s
+
+let rec string_of_ident = function
+ | <:ident< $lid:s$ >> -> s
+ | <:ident< $uid:s$ >> -> s
+ | <:ident< $i1$.$i2$ >> -> "acc_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
+ | <:ident< $i1$($i2$) >> -> "app_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
+ | <:ident< $anti:_$ >> -> assert false
+
+let fold_args ty f init =
+ let (_, res) =
+ List.fold_left begin fun (i, acc) ty ->
+ (succ i, f ty i acc)
+ end (0, init) ty
+ in res
+
+let fold_right_args ty f init =
+ let (_, res) =
+ List.fold_right begin fun ty (i, acc) ->
+ (pred i, f ty i acc)
+ end ty (List.length ty - 1, init)
+ in res
+
+let fold_data_ctors ty f init =
+ let counter () = let n = ref 0 in fun () -> let nn = !n in incr n; nn in
+ let tag = counter () in
+ let data_tag = counter () in
+ let rec loop acc t =
+ match t with
+ | <:ctyp< $uid:cons$ of $ty$ >> -> f (data_tag()) cons (Ast.list_of_ctyp ty []) acc
+ | <:ctyp< $uid:cons$ >> -> f (tag()) cons [] acc
+ | <:ctyp< $t1$ | $t2$ >> -> loop (loop acc t1) t2
+ | <:ctyp<>> -> acc
+ | _ -> assert false in
+ loop init ty
+
+let fold_type_decls m f init =
+ MapTy.fold f m.type_decls init
+
+let patt_of_data_ctor_decl cons tyargs =
+ fold_args tyargs begin fun _ i acc ->
+ Ast.PaApp(_loc, acc, <:patt< $id:x i$ >>)
+ end <:patt< $id:cons$ >>
+
+let expr_of_data_ctor_decl cons tyargs =
+ fold_args tyargs begin fun _ i acc ->
+ <:expr< $acc$ $id:x i$ >>
+ end <:expr< $id:cons$ >>
+
+let is_antiquot_data_ctor s =
+ let ls = String.length s in
+ ls > 3 && String.sub s (ls - 3) 3 = "Ant"
+
+let rec meta_ident m = function
+ | <:ident< $i1$.$i2$ >> -> <:expr< Ast.IdAcc(_loc, $meta_ident m i1$, $meta_ident m i2$) >>
+ | <:ident< $i1$($i2$) >> -> <:expr< Ast.IdApp(_loc, $meta_ident m i1$, $meta_ident m i2$) >>
+ | <:ident< $anti:s$ >> -> <:expr< $anti:s$ >>
+ | <:ident< $lid:s$ >> -> <:expr< Ast.IdLid(_loc, $str:s$) >>
+ | <:ident< $uid:s$ >> -> <:expr< Ast.IdUid(_loc, $str:s$) >>
+let m_app m x y = <:expr< $m.app$ _loc $x$ $y$ >>
+let m_id m i = <:expr< $m.id$ _loc $i$ >>
+let m_uid m s = m_id m (meta_ident m <:ident< $uid:s$ >>)
+
+let rec pmeta_ident m = function
+ | <:ident< $i1$.$i2$ >> -> <:patt< Ast.IdAcc(_, $pmeta_ident m i1$, $pmeta_ident m i2$) >>
+ | <:ident< $i1$($i2$) >> -> <:patt< Ast.IdApp(_, $pmeta_ident m i1$, $pmeta_ident m i2$) >>
+ | <:ident< $anti:s$ >> -> <:patt< $anti:s$ >>
+ | <:ident< $lid:s$ >> -> <:patt< Ast.IdLid(_, $str:s$) >>
+ | <:ident< $uid:s$ >> -> <:patt< Ast.IdUid(_, $str:s$) >>
+let pm_app m x y = <:patt< Ast.ExApp(_, $x$, $y$) >>
+let pm_id m i = <:patt< Ast.ExId(_, $i$) >>
+let pm_uid m s = pm_id m (pmeta_ident m <:ident< $uid:s$ >>)
+
+let failure = <:expr< raise (Failure "MetaGenerator: cannot handle that kind of types") >>
+
+let mk_meta m =
+ let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in
+ fold_type_decls m begin fun tyname tydcl binding_acc ->
+ match tydcl with
+ | Ast.TyDcl (_, _, tyvars, Ast.TySum (_, ty), _) ->
+ let match_case =
+ fold_data_ctors ty begin fun tag cons tyargs acc ->
+ let m_name_cons = m_name_uid cons in
+ let p = patt_of_data_ctor_decl m_name_cons tyargs 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 (x1, x2) ->
+ $m.tup$ _loc
+ ($m.com$ _loc
+ ($fcall_of_ctyp t1$ _loc x1)
+ ($fcall_of_ctyp t2$ _loc x2)) >>
+ | <: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
+ let funct =
+ List.fold_right begin fun tyvar acc ->
+ match tyvar with
+ | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> | <:ctyp< '$s$ >> ->
+ <:expr< fun $lid:mf_ s$ -> $acc$ >>
+ | _ -> assert false
+ end tyvars <:expr< fun _loc -> function $match_case$ >>
+ in <:binding< $binding_acc$ and $lid:"meta_"^tyname$ = $funct$ >>
+ | Ast.TyDcl (_, _, _, _, _) -> binding_acc
+ | _ -> assert false
+ end <:binding<>>
+
+let mk_abs_meta m =
+ let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in
+ fold_type_decls m begin fun tyname tydcl binding_acc ->
+ match tydcl with
+ | Ast.TyDcl (_, _, tyvars, Ast.TySum (_, ty), _) ->
+ let match_case =
+ fold_data_ctors ty begin fun tag cons tyargs acc ->
+ let m_name_cons = m_name_uid cons in
+ let p =
+ fold_args tyargs begin fun _ i acc ->
+ <: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
+ in <:match_case< $p$ -> $e$ | $acc$ >>
+ end <:match_case<>> in
+ let funct =
+ List.fold_right begin fun tyvar acc ->
+ match tyvar with
+ | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> | <:ctyp< '$s$ >> ->
+ <:expr< fun $lid:mf_ s$ -> $acc$ >>
+ | _ -> assert false
+ end tyvars <:expr< fun _loc -> function $match_case$ >>
+ in <:binding< $binding_acc$ and $lid:"meta_"^tyname$ = $funct$ >>
+ | Ast.TyDcl (_, _, _, _, _) -> binding_acc
+ | _ -> assert false
+ end <:binding<>>
+
+let find_type_decls =
+object
+ inherit Ast.fold as super
+ val accu = MapTy.empty
+ method get = accu
+ method ctyp = function
+ | Ast.TyDcl (_, name, _, _, _) as t -> {< accu = MapTy.add name t accu >}
+ | t -> super#ctyp t
+end
+
+let filter st =
+ let type_decls = lazy (find_type_decls#str_item st)#get in
+ object
+ inherit Ast.map as super
+ method module_expr me =
+ let mk_meta_module m =
+ let bi = mk_meta m in
+ <:module_expr<
+ struct
+ let meta_string _loc s = $m.str$ _loc s
+ let meta_int _loc s = $m.int$ _loc s
+ let meta_float _loc s = $m.flo$ _loc s
+ let meta_char _loc s = $m.chr$ _loc s
+(*
+ let meta_bool _loc b =
+ Lambda.Lconst
+ (Lambda.Const_pointer
+ ($m.int$ _loc (match b with false -> "0" | true -> "1")))
+*)
+ let meta_bool _loc = function
+ | false -> $m_uid m "False"$
+ | true -> $m_uid m "True"$
+ let rec meta_list mf_a _loc = function
+ | [] -> $m_uid m "[]"$
+ | x :: xs -> $m_app m (m_app m (m_uid m "::") <:expr< mf_a _loc x >>) <:expr< meta_list mf_a _loc xs >>$
+ let rec $bi$
+ end >> in
+ let mk_abs_meta_module m =
+ let bi = mk_abs_meta m in
+ <:module_expr<
+ struct
+ let meta_string _loc = function
+ | Ast.ExStr (_loc, s) -> $m.str$ _loc s
+ | _ -> invalid_arg "meta_string"
+ let meta_int _loc = function
+ | Ast.ExInt (loc, s) -> $m.int$ _loc s
+ | _ -> invalid_arg "meta_int"
+ let meta_float _loc = function
+ | Ast.ExFlo (_loc, s) -> $m.flo$ _loc s
+ | _ -> invalid_arg "meta_float"
+ let meta_char _loc = function
+ | Ast.ExChr (_loc, s) -> $m.chr$ _loc s
+ | _ -> invalid_arg "meta_char"
+(*
+ let meta_bool _loc b =
+ Lambda.Lconst
+ (Lambda.Const_pointer
+ ($m.int$ _loc (match b with false -> "0" | true -> "1")))
+*)
+ let meta_bool _loc = function
+ | <:expr< false >> -> $m_uid m "False"$
+ | <:expr< true >> -> $m_uid m "True"$
+ 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 >>$
+ let rec $bi$
+ end >> in
+ match super#module_expr me with
+ | <:module_expr< LambdaMetaGeneratorExpr($id:i$) >> ->
+ mk_meta_module (ex_t i type_decls)
+ | <:module_expr< LambdaAbstractMetaGeneratorExpr($id:i$) >> ->
+ mk_abs_meta_module (ex_t i type_decls)
+ | <:module_expr< LambdaMetaGeneratorPatt($id:i$) >> ->
+ mk_meta_module (pa_t i type_decls)
+ | <:module_expr< LambdaAbstractMetaGeneratorPatt($id:i$) >> ->
+ mk_abs_meta_module (pa_t i type_decls)
+ | me -> me
+ end#str_item st
+
+;;
+
+AstFilters.register_str_item_filter filter
View
169 src/jslib/syntax_lambda.ml
@@ -0,0 +1,169 @@
+(*
+ * This file is part of ocamljs, OCaml to Javascript compiler
+ * Copyright (C) 2007-9 Skydeck, Inc
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Library General Public License for more details.
+ *
+ * You should have received a copy of the GNU Library General Public
+ * License along with this library; if not, write to the Free
+ * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA
+ *)
+
+open Camlp4.PreCast
+
+module Q = Syntax.Quotation
+module TheAntiquotSyntax = Syntax.AntiquotSyntax
+
+(* I don't totally understand what's going on here but this is how
+ Camlp4QuotationCommon.ml does it. *)
+
+module MetaLocHere = Jslib_ast.Meta.MetaLoc
+module MetaLoc =
+struct
+ (* module Ast = Ast *)
+ let loc_name = ref None
+ let meta_loc_expr _loc loc =
+ match !loc_name with
+ | None -> <:expr< $lid:!Loc.name$ >>
+ | Some "here" -> MetaLocHere.meta_loc_expr _loc loc
+ | Some x -> <:expr< $lid:x$ >>
+ let meta_loc_patt _loc _ = <:patt< _ >>;
+end
+module MetaAst = Jslib_ast.Meta.MakeLambda(MetaLoc)
+module ME = MetaAst.Expr
+module MP = MetaAst.Patt
+module MetaAbstractAst = Jslib_ast.Meta.MakeAbstractLambda(MetaLoc)
+module MAE = MetaAbstractAst.Expr
+module MAP = MetaAbstractAst.Patt
+
+let is_antiquot s =
+ let len = String.length s in
+ len > 2 && s.[0] = '\\' && s.[1] = '$'
+
+let handle_antiquot_in_string s term parse loc decorate =
+ (* prerr_endline ("handle_antiquot_in_string " ^ s); *)
+ if is_antiquot s then
+ let pos = String.index s ':' in
+ let name = String.sub s 2 (pos - 2)
+ and code = String.sub s (pos + 1) (String.length s - pos - 1) in
+ decorate name (parse loc code)
+ else term
+
+let antiquot_expander =
+object
+ inherit Ast.map as super
+ method patt =
+ function
+ | <:patt@_loc< $anti:s$ >>
+ | <:patt@_loc< $str:s$ >> as p ->
+ handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p -> p)
+ | p -> super#patt p
+ method expr =
+ function
+ | <:expr@_loc< $anti:s$ >>
+ | <:expr@_loc< $str:s$ >> as e ->
+ handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e ->
+ match n with
+ | "`int" -> <:expr< string_of_int $e$ >>
+ | "`flo" -> <:expr< string_of_float $e$ >>
+ | "listexp" -> <:expr< Jslib_ast.exp_of_list $e$ >>
+ (* | "`str" -> <:expr< Ast.safe_string_escaped $e$ >> *)
+ | _ -> e )
+ | e -> super#expr e
+end
+
+let add_js_quotation name entry mexpr mpatt =
+ (* let entry_eoi = Jslib_parse.Gram.Entry.mk (Jslib_parse.Gram.Entry.name entry) in *)
+ let entry_eoi = entry in
+ let parse_quot_string entry loc s =
+ let q = !Camlp4_config.antiquotations in
+ let () = Camlp4_config.antiquotations := true in
+ let res = Jslib_parse.Gram.parse_string entry loc s in
+ let () = Camlp4_config.antiquotations := q in
+ res in
+ let expand_expr loc loc_name_opt s =
+ let ast = parse_quot_string entry_eoi loc s in
+ let () = MetaLoc.loc_name := loc_name_opt in
+ let meta_ast = mexpr loc ast in
+ let exp_ast = antiquot_expander#expr meta_ast in
+ exp_ast in
+ let expand_str_item loc loc_name_opt s =
+ let exp_ast = expand_expr loc loc_name_opt s in
+ <:str_item@loc< $exp:exp_ast$ >> in
+ let expand_patt _loc loc_name_opt s =
+ let ast = parse_quot_string entry_eoi _loc s in
+ let meta_ast = mpatt _loc ast in
+ let exp_ast = antiquot_expander#patt meta_ast in
+ match loc_name_opt with
+ | None -> exp_ast
+ | Some name ->
+ let rec subst_first_loc =
+ function
+ | <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
+ | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
+ | p -> p in
+ subst_first_loc exp_ast in
+ (*
+ EXTEND Jslib_parse.Gram
+ entry_eoi:
+ [ [ x = entry; `EOI -> x ] ]
+ ;
+ END;
+ *)
+ Q.add name Q.DynAst.expr_tag expand_expr;
+ Q.add name Q.DynAst.patt_tag expand_patt;
+ Q.add name Q.DynAst.str_item_tag expand_str_item
+
+let add_ocaml_quotation name entry mexpr mpatt =
+ let entry_eoi = Syntax.Gram.Entry.mk (Syntax.Gram.Entry.name entry) in
+ let parse_quot_string entry loc s =
+ let q = !Camlp4_config.antiquotations in
+ let () = Camlp4_config.antiquotations := true in
+ let res = Syntax.Gram.parse_string entry loc s in
+ let () = Camlp4_config.antiquotations := q in
+ res in
+ let expand_expr loc loc_name_opt s =
+ let ast = parse_quot_string entry_eoi loc s in
+ let () = MetaLoc.loc_name := loc_name_opt in
+ let meta_ast = mexpr loc ast in
+ let exp_ast = antiquot_expander#expr meta_ast in
+ exp_ast in
+ let expand_str_item loc loc_name_opt s =
+ let exp_ast = expand_expr loc loc_name_opt s in
+ <:str_item@loc< $exp:exp_ast$ >> in
+ let expand_patt _loc loc_name_opt s =
+ let ast = parse_quot_string entry_eoi _loc s in
+ let meta_ast = mpatt _loc ast in
+ let exp_ast = antiquot_expander#patt meta_ast in
+ match loc_name_opt with
+ | None -> exp_ast
+ | Some name ->
+ let rec subst_first_loc =
+ function
+ | <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >>
+ | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >>
+ | p -> p in
+ subst_first_loc exp_ast in
+ EXTEND Syntax.Gram
+ entry_eoi:
+ [ [ x = entry; `EOI -> x ] ]
+ ;
+ END;
+ Q.add name Q.DynAst.expr_tag expand_expr;
+ Q.add name Q.DynAst.patt_tag expand_patt;
+ Q.add name Q.DynAst.str_item_tag expand_str_item
+;;
+
+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;
View
5 tools/myocamlbuild.ml
@@ -205,6 +205,11 @@ dispatch begin function
flag ["ocaml"; "compile"; "OCAML_3_10_2"] & S[A"-ppopt"; A"-DOCAML_3_10_2"];
flag ["ocaml"; "ocamldep"; "OCAML_3_10_2"] & S[A"-ppopt"; A"-DOCAML_3_10_2"];
+ (* XXX should put these in jslib only *)
+ flag ["ocaml"; "compile"; "lambda_meta_generator"] & S[A"-ppopt"; A"lambda_meta_generator.cmo"];
+ flag ["ocaml"; "ocamldep"; "lambda_meta_generator"] & S[A"-ppopt"; A"lambda_meta_generator.cmo"];
+ dep ["lambda_meta_generator"] ["lambda_meta_generator.cmo"];
+
| _ -> ()
end

0 comments on commit 30af97c

Please sign in to comment.