diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast.mlast')
| -rw-r--r-- | ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast.mlast | 544 |
1 files changed, 544 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast.mlast new file mode 100644 index 0000000000..4c692a380e --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -0,0 +1,544 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Loc : Sig.Loc) +: Sig.Camlp4Ast with module Loc = Loc += struct + module Loc = Loc; + + module Ast = struct + include Sig.MakeCamlp4Ast Loc; + + value safe_string_escaped s = + if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s + else String.escaped s; + end; + + include Ast; + + external loc_of_ctyp : ctyp -> Loc.t = "%field0"; + external loc_of_patt : patt -> Loc.t = "%field0"; + external loc_of_expr : expr -> Loc.t = "%field0"; + external loc_of_module_type : module_type -> Loc.t = "%field0"; + external loc_of_module_expr : module_expr -> Loc.t = "%field0"; + external loc_of_sig_item : sig_item -> Loc.t = "%field0"; + external loc_of_str_item : str_item -> Loc.t = "%field0"; + external loc_of_class_type : class_type -> Loc.t = "%field0"; + external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; + external loc_of_class_expr : class_expr -> Loc.t = "%field0"; + external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; + external loc_of_with_constr : with_constr -> Loc.t = "%field0"; + external loc_of_binding : binding -> Loc.t = "%field0"; + external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; + external loc_of_module_binding : module_binding -> Loc.t = "%field0"; + external loc_of_match_case : match_case -> Loc.t = "%field0"; + external loc_of_ident : ident -> Loc.t = "%field0"; + + value ghost = Loc.ghost; + + value rec is_module_longident = + fun + [ <:ident< $_$.$i$ >> -> is_module_longident i + | <:ident< $i1$ $i2$ >> -> + is_module_longident i1 && is_module_longident i2 + | <:ident< $uid:_$ >> -> True + | _ -> False ]; + + value ident_of_expr = + let error () = + invalid_arg "ident_of_expr: this expression is not an identifier" in + let rec self = + fun + [ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >> + | <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >> + | <:expr< $lid:_$ >> -> error () + | <:expr< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:expr< $id:i$ >> -> i + | <:expr< $_$ $_$ >> -> error () + | t -> self t ]; + + value ident_of_ctyp = + let error () = + invalid_arg "ident_of_ctyp: this type is not an identifier" in + let rec self = + fun + [ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >> + | <:ctyp< $lid:_$ >> -> error () + | <:ctyp< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:ctyp< $id:i$ >> -> i + | t -> self t ]; + + value ident_of_patt = + let error () = + invalid_arg "ident_of_patt: this pattern is not an identifier" in + let rec self = + fun + [ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >> + | <:patt< $lid:_$ >> -> error () + | <:patt< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:patt< $id:i$ >> -> i + | p -> self p ]; + + value rec is_irrefut_patt = + fun + [ <:patt< $lid:_$ >> -> True + | <:patt< () >> -> True + | <:patt< _ >> -> True + | <:patt<>> -> True (* why not *) + | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y + | <:patt< { $p$ } >> -> is_irrefut_patt p + | <:patt< $_$ = $p$ >> -> is_irrefut_patt p + | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) + | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p + | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl + | <:patt< ? $_$ >> -> True + | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p + | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True + | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p + | <:patt< lazy $p$ >> -> is_irrefut_patt p + | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) + | <:patt< (module $_$) >> -> True + | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | + <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | + <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | + <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False + ]; + + value rec is_constructor = + fun + [ <:ident< $_$.$i$ >> -> is_constructor i + | <:ident< $uid:_$ >> -> True + | <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False + | <:ident< $anti:_$ >> -> assert False ]; + + value is_patt_constructor = + fun + [ <:patt< $id:i$ >> -> is_constructor i + | <:patt< `$_$ >> -> True + | _ -> False ]; + + value rec is_expr_constructor = + fun + [ <:expr< $id:i$ >> -> is_constructor i + | <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2 + | <:expr< `$_$ >> -> True + | _ -> False ]; + + value rec tyOr_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ]; + + value rec tyAnd_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ]; + + value rec tySem_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ]; + + value rec tyCom_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ]; + + value rec tyAmp_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ]; + + value rec tySta_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ]; + + value rec stSem_of_list = + fun + [ [] -> <:str_item@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ]; + + value rec sgSem_of_list = + fun + [ [] -> <:sig_item@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ]; + + value rec biAnd_of_list = + fun + [ [] -> <:binding@ghost<>> + | [b] -> b + | [b::bs] -> + let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ]; + + value rec rbSem_of_list = + fun + [ [] -> <:rec_binding@ghost<>> + | [b] -> b + | [b::bs] -> + let _loc = loc_of_rec_binding b in + <:rec_binding< $b$; $rbSem_of_list bs$ >> ]; + + value rec wcAnd_of_list = + fun + [ [] -> <:with_constr@ghost<>> + | [w] -> w + | [w::ws] -> + let _loc = loc_of_with_constr w in + <:with_constr< $w$ and $wcAnd_of_list ws$ >> ]; + + value rec idAcc_of_list = + fun + [ [] -> assert False + | [i] -> i + | [i::is] -> + let _loc = loc_of_ident i in + <:ident< $i$ . $idAcc_of_list is$ >> ]; + + value rec idApp_of_list = + fun + [ [] -> assert False + | [i] -> i + | [i::is] -> + let _loc = loc_of_ident i in + <:ident< $i$ $idApp_of_list is$ >> ]; + + value rec mcOr_of_list = + fun + [ [] -> <:match_case@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_match_case x in + <:match_case< $x$ | $mcOr_of_list xs$ >> ]; + + value rec mbAnd_of_list = + fun + [ [] -> <:module_binding@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_module_binding x in + <:module_binding< $x$ and $mbAnd_of_list xs$ >> ]; + + value rec meApp_of_list = + fun + [ [] -> assert False + | [x] -> x + | [x::xs] -> + let _loc = loc_of_module_expr x in + <:module_expr< $x$ $meApp_of_list xs$ >> ]; + + value rec ceAnd_of_list = + fun + [ [] -> <:class_expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_expr x in + <:class_expr< $x$ and $ceAnd_of_list xs$ >> ]; + + value rec ctAnd_of_list = + fun + [ [] -> <:class_type@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_type x in + <:class_type< $x$ and $ctAnd_of_list xs$ >> ]; + + value rec cgSem_of_list = + fun + [ [] -> <:class_sig_item@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_sig_item x in + <:class_sig_item< $x$; $cgSem_of_list xs$ >> ]; + + value rec crSem_of_list = + fun + [ [] -> <:class_str_item@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_str_item x in + <:class_str_item< $x$; $crSem_of_list xs$ >> ]; + + value rec paSem_of_list = + fun + [ [] -> <:patt@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_patt x in + <:patt< $x$; $paSem_of_list xs$ >> ]; + + value rec paCom_of_list = + fun + [ [] -> <:patt@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_patt x in + <:patt< $x$, $paCom_of_list xs$ >> ]; + + value rec exSem_of_list = + fun + [ [] -> <:expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_expr x in + <:expr< $x$; $exSem_of_list xs$ >> ]; + + value rec exCom_of_list = + fun + [ [] -> <:expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_expr x in + <:expr< $x$, $exCom_of_list xs$ >> ]; + + value ty_of_stl = + fun + [ (_loc, s, []) -> <:ctyp< $uid:s$ >> + | (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ]; + + value ty_of_sbt = + fun + [ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >> + | (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ]; + + value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>; + value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); + value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); + value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); + + value rec pel_of_binding = + fun + [ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 + | <:binding< $p$ = $e$ >> -> [(p, e)] + | _ -> assert False ]; + + value rec list_of_binding x acc = + match x with + [ <:binding< $b1$ and $b2$ >> -> + list_of_binding b1 (list_of_binding b2 acc) + | t -> [t :: acc] ]; + + value rec list_of_rec_binding x acc = + match x with + [ <:rec_binding< $b1$; $b2$ >> -> + list_of_rec_binding b1 (list_of_rec_binding b2 acc) + | t -> [t :: acc] ]; + + value rec list_of_with_constr x acc = + match x with + [ <:with_constr< $w1$ and $w2$ >> -> + list_of_with_constr w1 (list_of_with_constr w2 acc) + | t -> [t :: acc] ]; + + value rec list_of_ctyp x acc = + match x with + [ <:ctyp<>> -> acc + | <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> | + <:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> | + <:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> -> + list_of_ctyp x (list_of_ctyp y acc) + | x -> [x :: acc] ]; + + value rec list_of_patt x acc = + match x with + [ <:patt<>> -> acc + | <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> -> + list_of_patt x (list_of_patt y acc) + | x -> [x :: acc] ]; + + value rec list_of_expr x acc = + match x with + [ <:expr<>> -> acc + | <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> -> + list_of_expr x (list_of_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_str_item x acc = + match x with + [ <:str_item<>> -> acc + | <:str_item< $x$; $y$ >> -> + list_of_str_item x (list_of_str_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_sig_item x acc = + match x with + [ <:sig_item<>> -> acc + | <:sig_item< $x$; $y$ >> -> + list_of_sig_item x (list_of_sig_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_sig_item x acc = + match x with + [ <:class_sig_item<>> -> acc + | <:class_sig_item< $x$; $y$ >> -> + list_of_class_sig_item x (list_of_class_sig_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_str_item x acc = + match x with + [ <:class_str_item<>> -> acc + | <:class_str_item< $x$; $y$ >> -> + list_of_class_str_item x (list_of_class_str_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_type x acc = + match x with + [ <:class_type< $x$ and $y$ >> -> + list_of_class_type x (list_of_class_type y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_expr x acc = + match x with + [ <:class_expr< $x$ and $y$ >> -> + list_of_class_expr x (list_of_class_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_module_expr x acc = + match x with + [ <:module_expr< $x$ $y$ >> -> + list_of_module_expr x (list_of_module_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_match_case x acc = + match x with + [ <:match_case<>> -> acc + | <:match_case< $x$ | $y$ >> -> + list_of_match_case x (list_of_match_case y acc) + | x -> [x :: acc] ]; + + value rec list_of_ident x acc = + match x with + [ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> -> + list_of_ident x (list_of_ident y acc) + | x -> [x :: acc] ]; + + value rec list_of_module_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + list_of_module_binding x (list_of_module_binding y acc) + | x -> [x :: acc] ]; + + module Camlp4Trash = struct + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + end; + + module Meta = struct + + module type META_LOC = sig + (** The first location is where to put the returned pattern. + Generally it's _loc to match with <:patt< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; + (** The first location is where to put the returned expression. + Generally it's _loc to match with <:expr< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; + end; + + module MetaLoc = struct + value meta_loc_patt _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in + <:patt< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:patt< True >> else <:patt< False >> $) >>; + value meta_loc_expr _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in + <:expr< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:expr< True >> else <:expr< False >> $) >>; + end; + + module MetaGhostLoc = struct + value meta_loc_patt _loc _ = <:patt< Loc.ghost >>; + value meta_loc_expr _loc _ = <:expr< Loc.ghost >>; + end; + + module MetaLocVar = struct + value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>; + value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>; + end; + + module Make (MetaLoc : META_LOC) = struct + open MetaLoc; + + value meta_loc = meta_loc_expr; + module Expr = Camlp4Filters.MetaGeneratorExpr Ast; + value meta_loc = meta_loc_patt; + module Patt = Camlp4Filters.MetaGeneratorPatt Ast; + end; + + end; + + class map = Camlp4MapGenerator.generated; + + class fold = Camlp4FoldGenerator.generated; + + value map_expr f = object + inherit map as super; + method expr x = f (super#expr x); + end; + value map_patt f = object + inherit map as super; + method patt x = f (super#patt x); + end; + value map_ctyp f = object + inherit map as super; + method ctyp x = f (super#ctyp x); + end; + value map_str_item f = object + inherit map as super; + method str_item x = f (super#str_item x); + end; + value map_sig_item f = object + inherit map as super; + method sig_item x = f (super#sig_item x); + end; + value map_loc f = object + inherit map as super; + method loc x = f (super#loc x); + end; +end; |