diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/Camlp4/Struct')
40 files changed, 6118 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/.cvsignore b/ocaml-binary-annot/camlp4/Camlp4/Struct/.cvsignore new file mode 100644 index 0000000000..262784dbd7 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/.cvsignore @@ -0,0 +1,2 @@ +Lexer.ml +Camlp4Ast.tmp.ml diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/AstFilters.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/AstFilters.ml new file mode 100644 index 0000000000..665e610aff --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/AstFilters.ml @@ -0,0 +1,37 @@ +(****************************************************************************) +(* *) +(* 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 (Ast : Sig.Camlp4Ast) +: Sig.AstFilters with module Ast = Ast += struct + + module Ast = Ast; + + type filter 'a = 'a -> 'a; + + value interf_filters = Queue.create (); + value fold_interf_filters f i = Queue.fold f i interf_filters; + value implem_filters = Queue.create (); + value fold_implem_filters f i = Queue.fold f i implem_filters; + value topphrase_filters = Queue.create (); + value fold_topphrase_filters f i = Queue.fold f i topphrase_filters; + + value register_sig_item_filter f = Queue.add f interf_filters; + value register_str_item_filter f = Queue.add f implem_filters; + value register_topphrase_filter f = Queue.add f topphrase_filters; +end; 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; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml new file mode 100644 index 0000000000..9146fa25d0 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -0,0 +1,1110 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-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 (Ast : Sig.Camlp4Ast) = struct + open Format; + open Camlp4_import.Parsetree; + open Camlp4_import.Longident; + open Camlp4_import.Asttypes; + open Ast; + + value constructors_arity () = + debug ast2pt "constructors_arity: %b@." Camlp4_config.constructors_arity.val in + Camlp4_config.constructors_arity.val; + + value error loc str = Loc.raise loc (Failure str); + + value char_of_char_token loc s = + try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ] + ; + + value string_of_string_token loc s = + try Token.Eval.string s + with [ Failure _ as exn -> Loc.raise loc exn ] + ; + + value remove_underscores s = + let l = String.length s in + let rec remove src dst = + if src >= l then + if dst >= l then s else String.sub s 0 dst + else + match s.[src] with + [ '_' -> remove (src + 1) dst + | c -> do { s.[dst] := c; remove (src + 1) (dst + 1) } ] + in remove 0 0 + ; + + value mkloc = Loc.to_ocaml_location; + value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); + + value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; + value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; + value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; + value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; + value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; + value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; + value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; + value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; + value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; + value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; + value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; + value mkpolytype t = + match t.ptyp_desc with + [ Ptyp_poly _ _ -> t + | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] + ; + + value mkvirtual = fun + [ <:virtual_flag< virtual >> -> Virtual + | <:virtual_flag<>> -> Concrete + | _ -> assert False ]; + + value mkdirection = fun + [ <:direction_flag< to >> -> Upto + | <:direction_flag< downto >> -> Downto + | _ -> assert False ]; + + value lident s = Lident s; + value ldot l s = Ldot l s; + value lapply l s = Lapply l s; + + value conv_con = + let t = Hashtbl.create 73 in + do { + List.iter (fun (s, s') -> Hashtbl.add t s s') + [("True", "true"); ("False", "false"); (" True", "True"); + (" False", "False")]; + fun s -> try Hashtbl.find t s with [ Not_found -> s ] + } + ; + + value conv_lab = + let t = Hashtbl.create 73 in + do { + List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; + fun s -> try Hashtbl.find t s with [ Not_found -> s ] + } + ; + + value array_function str name = + ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) + ; + + value mkrf = + fun + [ <:rec_flag< rec >> -> Recursive + | <:rec_flag<>> -> Nonrecursive + | _ -> assert False ]; + + value mkli s = loop lident + where rec loop f = + fun + [ [i :: il] -> loop (ldot (f i)) il + | [] -> f s ] + ; + + value rec ctyp_fa al = + fun + [ TyApp _ f a -> ctyp_fa [a :: al] f + | f -> (f, al) ] + ; + + value ident_tag ?(conv_lid = fun x -> x) i = + + let rec self i acc = + match i with + [ <:ident< $i1$.$i2$ >> -> + self i2 (Some (self i1 acc)) + | <:ident< $i1$ $i2$ >> -> + let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in + let x = + match acc with + [ None -> i' + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `app) + | <:ident< $uid:s$ >> -> + let x = + match acc with + [ None -> lident s + | Some (acc, `uident | `app) -> ldot acc s + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `uident) + | <:ident< $lid:s$ >> -> + let x = + match acc with + [ None -> lident (conv_lid s) + | Some (acc, `uident | `app) -> ldot acc (conv_lid s) + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `lident) + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in self i None; + + value ident ?conv_lid i = fst (ident_tag ?conv_lid i); + + value long_lident msg i = + match ident_tag i with + [ (i, `lident) -> i + | _ -> error (loc_of_ident i) msg ] + ; + + value long_type_ident = long_lident "invalid long identifier type"; + value long_class_ident = long_lident "invalid class name"; + + value long_uident ?(conv_con = fun x -> x) i = + match ident_tag i with + [ (Ldot i s, `uident) -> ldot i (conv_con s) + | (Lident s, `uident) -> lident (conv_con s) + | (i, `app) -> i + | _ -> error (loc_of_ident i) "uppercase identifier expected" ] + ; + + value rec ctyp_long_id_prefix t = + match t with + [ <:ctyp< $id:i$ >> -> ident i + | <:ctyp< $m1$ $m2$ >> -> + let li1 = ctyp_long_id_prefix m1 in + let li2 = ctyp_long_id_prefix m2 in + Lapply li1 li2 + | t -> error (loc_of_ctyp t) "invalid module expression" ] + ; + + value ctyp_long_id t = + match t with + [ <:ctyp< $id:i$ >> -> + (False, long_type_ident i) + | TyApp loc _ _ -> + error loc "invalid type name" + | TyCls _ i -> (True, ident i) + | t -> error (loc_of_ctyp t) "invalid type" ] + ; + + value rec ty_var_list_of_ctyp = + fun + [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 + | <:ctyp< '$s$ >> -> [s] + | _ -> assert False ]; + + value rec ctyp = + fun + [ TyId loc i -> + let li = long_type_ident i in + mktyp loc (Ptyp_constr li []) + | TyAli loc t1 t2 -> + let (t, i) = + match (t1, t2) with + [ (t, TyQuo _ s) -> (t, s) + | (TyQuo _ s, t) -> (t, s) + | _ -> error loc "invalid alias type" ] + in + mktyp loc (Ptyp_alias (ctyp t) i) + | TyAny loc -> mktyp loc Ptyp_any + | TyApp loc _ _ as f -> + let (f, al) = ctyp_fa [] f in + let (is_cls, li) = ctyp_long_id f in + if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) + else mktyp loc (Ptyp_constr li (List.map ctyp al)) + | TyArr loc (TyLab _ lab t1) t2 -> + mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) + | TyArr loc (TyOlb loc1 lab t1) t2 -> + let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in + mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) + | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) + | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) + | <:ctyp@loc< < $fl$ .. > >> -> + mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) + | TyCls loc id -> + mktyp loc (Ptyp_class (ident id) [] []) + | <:ctyp@loc< (module $pt$) >> -> + let (i, cs) = package_type pt in + mktyp loc (Ptyp_package i cs) + | TyLab loc _ _ -> error loc "labelled type not allowed here" + | TyMan loc _ _ -> error loc "manifest type not allowed here" + | TyOlb loc _ _ -> error loc "labelled type not allowed here" + | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2)) + | TyQuo loc s -> mktyp loc (Ptyp_var s) + | TyRec loc _ -> error loc "record type not allowed here" + | TySum loc _ -> error loc "sum type not allowed here" + | TyPrv loc _ -> error loc "private type not allowed here" + | TyMut loc _ -> error loc "mutable type not allowed here" + | TyOr loc _ _ -> error loc "type1 | type2 not allowed here" + | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here" + | TyOf loc _ _ -> error loc "type1 of type2 not allowed here" + | TyCol loc _ _ -> error loc "type1 : type2 not allowed here" + | TySem loc _ _ -> error loc "type1 ; type2 not allowed here" + | <:ctyp@loc< ($t1$ * $t2$) >> -> + mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) + | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True None) + | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None) + | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some [])) + | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> + mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t'))) + | TyAnt loc _ -> error loc "antiquotation not allowed here" + | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | + TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | + TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> + assert False ] + and row_field = fun + [ <:ctyp<>> -> [] + | <:ctyp< `$i$ >> -> [Rtag i True []] + | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))] + | <:ctyp< `$i$ of $t$ >> -> [Rtag i False (List.map ctyp (list_of_ctyp t []))] + | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2 + | t -> [Rinherit (ctyp t)] ] + and name_tags = fun + [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2 + | <:ctyp< `$s$ >> -> [s] + | _ -> assert False ] + and meth_list fl acc = + match fl with + [ <:ctyp<>> -> acc + | <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) + | <:ctyp@loc< $lid:lab$ : $t$ >> -> + [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc] + | _ -> assert False ] + + and package_type_constraints wc acc = + match wc with + [ <:with_constr<>> -> acc + | <:with_constr< type $lid:id$ = $ct$ >> -> + [(id, ctyp ct) :: acc] + | <:with_constr< $wc1$ and $wc2$ >> -> + package_type_constraints wc1 (package_type_constraints wc2 acc) + | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] + + and package_type : module_type -> package_type = + fun + [ <:module_type< $id:i$ with $wc$ >> -> + (long_uident i, package_type_constraints wc []) + | <:module_type< $id:i$ >> -> (long_uident i, []) + | mt -> error (loc_of_module_type mt) "unexpected package type" ] + ; + + value mktype loc tl cl tk tp tm = + let (params, variance) = List.split tl in + {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; + ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; + ptype_variance = variance} + ; + value mkprivate' m = if m then Private else Public; + value mkprivate = fun + [ <:private_flag< private >> -> Private + | <:private_flag<>> -> Public + | _ -> assert False ]; + value mktrecord = + fun + [ <:ctyp@loc< $lid:s$ : mutable $t$ >> -> + (s, Mutable, mkpolytype (ctyp t), mkloc loc) + | <:ctyp@loc< $lid:s$ : $t$ >> -> + (s, Immutable, mkpolytype (ctyp t), mkloc loc) + | _ -> assert False (*FIXME*) ]; + value mkvariant = + fun + [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc) + | <:ctyp@loc< $uid:s$ of $t$ >> -> + (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc) + | _ -> assert False (*FIXME*) ]; + value rec type_decl tl cl loc m pflag = + fun + [ <:ctyp< $t1$ == $t2$ >> -> + type_decl tl cl loc (Some (ctyp t1)) pflag t2 + | <:ctyp< private $t$ >> -> + type_decl tl cl loc m True t + | <:ctyp< { $t$ } >> -> + mktype loc tl cl + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m + | <:ctyp< [ $t$ ] >> -> + mktype loc tl cl + (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m + | t -> + if m <> None then + error loc "only one manifest type allowed by definition" else + let m = + match t with + [ <:ctyp<>> -> None + | _ -> Some (ctyp t) ] + in + mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] + ; + + value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; + + value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; + + value rec list_of_meta_list = + fun + [ Ast.LNil -> [] + | Ast.LCons x xs -> [x :: list_of_meta_list xs] + | Ast.LAnt _ -> assert False ]; + + value mkmutable = fun + [ <:mutable_flag< mutable >> -> Mutable + | <:mutable_flag<>> -> Immutable + | _ -> assert False ]; + + value paolab lab p = + match (lab, p) with + [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i + | ("", p) -> error (loc_of_patt p) "bad ast in label" + | _ -> lab ] + ; + + value opt_private_ctyp = + fun + [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) + | t -> (Ptype_abstract, Public, ctyp t) ]; + + value rec type_parameters t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] + | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] + | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] + | _ -> assert False ]; + + value rec class_parameters t acc = + match t with + [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] + | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] + | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] + | _ -> assert False ]; + + value rec type_parameters_and_type_name t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> + type_parameters_and_type_name t1 + (type_parameters t2 acc) + | <:ctyp< $id:i$ >> -> (ident i, acc) + | _ -> assert False ]; + + value mkwithtyp pwith_type loc id_tpl ct = + let (id, tpl) = type_parameters_and_type_name id_tpl [] in + let (params, variance) = List.split tpl in + let (kind, priv, ct) = opt_private_ctyp ct in + (id, pwith_type + {ptype_params = params; ptype_cstrs = []; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = Some ct; + ptype_loc = mkloc loc; ptype_variance = variance}); + + value rec mkwithc wc acc = + match wc with + [ <:with_constr<>> -> acc + | <:with_constr@loc< type $id_tpl$ = $ct$ >> -> + [mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc] + | <:with_constr< module $i1$ = $i2$ >> -> + [(long_uident i1, Pwith_module (long_uident i2)) :: acc] + | <:with_constr@loc< type $id_tpl$ := $ct$ >> -> + [mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc] + | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) -> + [(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc] + | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc) + | <:with_constr@loc< $anti:_$ >> -> + error loc "bad with constraint (antiquotation)" ]; + + value rec patt_fa al = + fun + [ PaApp _ f a -> patt_fa [a :: al] f + | f -> (f, al) ] + ; + + value rec deep_mkrangepat loc c1 c2 = + if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) + else + mkghpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) + (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) + ; + + value rec mkrangepat loc c1 c2 = + if c1 > c2 then mkrangepat loc c2 c1 + else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) + else + mkpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) + (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) + ; + + value rec patt = + fun + [ <:patt@loc< $lid:s$ >> -> mkpat loc (Ppat_var s) + | <:patt@loc< $id:i$ >> -> + let p = Ppat_construct (long_uident ~conv_con i) + None (constructors_arity ()) + in mkpat loc p + | PaAli loc p1 p2 -> + let (p, i) = + match (p1, p2) with + [ (p, <:patt< $lid:s$ >>) -> (p, s) + | (<:patt< $lid:s$ >>, p) -> (p, s) + | _ -> error loc "invalid alias pattern" ] + in + mkpat loc (Ppat_alias (patt p) i) + | PaAnt loc _ -> error loc "antiquotation not allowed here" + | PaAny loc -> mkpat loc Ppat_any + | <:patt@loc< $uid:s$ ($tup:<:patt@loc_any< _ >>$) >> -> + mkpat loc (Ppat_construct (lident (conv_con s)) + (Some (mkpat loc_any Ppat_any)) False) + | PaApp loc _ _ as f -> + let (f, al) = patt_fa [] f in + let al = List.map patt al in + match (patt f).ppat_desc with + [ Ppat_construct li None _ -> + if constructors_arity () then + mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True) + else + let a = + match al with + [ [a] -> a + | _ -> mkpat loc (Ppat_tuple al) ] + in + mkpat loc (Ppat_construct li (Some a) False) + | Ppat_variant s None -> + let a = + if constructors_arity () then + mkpat loc (Ppat_tuple al) + else + match al with + [ [a] -> a + | _ -> mkpat loc (Ppat_tuple al) ] + in mkpat loc (Ppat_variant s (Some a)) + | _ -> + error (loc_of_patt f) + "this is not a constructor, it cannot be applied in a pattern" ] + | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) + | PaChr loc s -> + mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) + | PaInt loc s -> + let i = try int_of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" + ] in mkpat loc (Ppat_constant (Const_int i)) + | PaInt32 loc s -> + let i32 = try Int32.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" + ] in mkpat loc (Ppat_constant (Const_int32 i32)) + | PaInt64 loc s -> + let i64 = try Int64.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" + ] in mkpat loc (Ppat_constant (Const_int64 i64)) + | PaNativeInt loc s -> + let nati = try Nativeint.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" + ] in mkpat loc (Ppat_constant (Const_nativeint nati)) + | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s))) + | PaLab loc _ _ -> error loc "labeled pattern not allowed here" + | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here" + | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) + | PaRng loc p1 p2 -> + match (p1, p2) with + [ (PaChr loc1 c1, PaChr loc2 c2) -> + let c1 = char_of_char_token loc1 c1 in + let c2 = char_of_char_token loc2 c2 in + mkrangepat loc c1 c2 + | _ -> error loc "range pattern allowed only for characters" ] + | PaRec loc p -> + let ps = list_of_patt p [] in + let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in + let (wildcards,ps) = List.partition is_wildcard ps in + let is_closed = if wildcards = [] then Closed else Open in + mkpat loc (Ppat_record (List.map mklabpat ps, is_closed)) + | PaStr loc s -> + mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) + | <:patt@loc< ($p1$, $p2$) >> -> + mkpat loc (Ppat_tuple + (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) + | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" + | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) + | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) + | PaVrn loc s -> mkpat loc (Ppat_variant s None) + | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) + | PaMod loc m -> mkpat loc (Ppat_unpack m) + | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> + error (loc_of_patt p) "invalid pattern" ] + and mklabpat = + fun + [ <:patt< $i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p) + | p -> error (loc_of_patt p) "invalid pattern" ]; + + value rec expr_fa al = + fun + [ ExApp _ f a -> expr_fa [a :: al] f + | f -> (f, al) ] + ; + + value rec class_expr_fa al = + fun + [ CeApp _ ce a -> class_expr_fa [a :: al] ce + | ce -> (ce, al) ] + ; + + + value rec sep_expr_acc l = + fun + [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 + | <:expr@loc< $uid:s$ >> as e -> + match l with + [ [] -> [(loc, [], e)] + | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ] + | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> -> + let rec normalize_acc = + fun + [ <:ident@_loc< $i1$.$i2$ >> -> + <:expr< $normalize_acc i1$.$normalize_acc i2$ >> + | <:ident@_loc< $i1$ $i2$ >> -> + <:expr< $normalize_acc i1$ $normalize_acc i2$ >> + | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> | + <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ] + in sep_expr_acc l (normalize_acc i) + | e -> [(loc_of_expr e, [], e) :: l] ] + ; + + value override_flag loc = + fun [ <:override_flag< ! >> -> Override + | <:override_flag<>> -> Fresh + | _ -> error loc "antiquotation not allowed here" + ]; + + value list_of_opt_ctyp ot acc = + match ot with + [ <:ctyp<>> -> acc + | t -> list_of_ctyp t acc ]; + + value rec expr = + fun + [ <:expr@loc< $x$.val >> -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)]) + | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e -> + let (e, l) = + match sep_expr_acc [] e with + [ [(loc, ml, <:expr< $uid:s$ >>) :: l] -> + let ca = constructors_arity () in + (mkexp loc (Pexp_construct (mkli (conv_con s) ml) None ca), l) + | [(loc, ml, <:expr< $lid:s$ >>) :: l] -> + (mkexp loc (Pexp_ident (mkli s ml)), l) + | [(_, [], e) :: l] -> (expr e, l) + | _ -> error loc "bad ast in expression" ] + in + let (_, e) = + List.fold_left + (fun (loc_bp, e1) (loc_ep, ml, e2) -> + match e2 with + [ <:expr< $lid:s$ >> -> + let loc = Loc.merge loc_bp loc_ep + in (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml))) + | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) + (loc, e) l + in + e + | ExAnt loc _ -> error loc "antiquotation not allowed here" + | ExApp loc _ _ as f -> + let (f, al) = expr_fa [] f in + let al = List.map label_expr al in + match (expr f).pexp_desc with + [ Pexp_construct li None _ -> + let al = List.map snd al in + if constructors_arity () then + mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True) + else + let a = + match al with + [ [a] -> a + | _ -> mkexp loc (Pexp_tuple al) ] + in + mkexp loc (Pexp_construct li (Some a) False) + | Pexp_variant s None -> + let al = List.map snd al in + let a = + if constructors_arity () then + mkexp loc (Pexp_tuple al) + else + match al with + [ [a] -> a + | _ -> mkexp loc (Pexp_tuple al) ] + in mkexp loc (Pexp_variant s (Some a)) + | _ -> mkexp loc (Pexp_apply (expr f) al) ] + | ExAre loc e1 e2 -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get"))) + [("", expr e1); ("", expr e2)]) + | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) + | ExAsf loc -> mkexp loc Pexp_assertfalse + | ExAss loc e v -> + let e = + match e with + [ <:expr@loc< $x$.val >> -> + Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) + [("", expr x); ("", expr v)] + | ExAcc loc _ _ -> + match (expr e).pexp_desc with + [ Pexp_field e lab -> Pexp_setfield e lab (expr v) + | _ -> error loc "bad record access" ] + | ExAre _ e1 e2 -> + Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) + [("", expr e1); ("", expr e2); ("", expr v)] + | <:expr< $lid:lab$ >> -> Pexp_setinstvar lab (expr v) + | ExSte _ e1 e2 -> + Pexp_apply + (mkexp loc (Pexp_ident (array_function "String" "set"))) + [("", expr e1); ("", expr e2); ("", expr v)] + | _ -> error loc "bad left part of assignment" ] + in + mkexp loc e + | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) + | ExChr loc s -> + mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) + | ExCoe loc e t1 t2 -> + let t1 = + match t1 with + [ <:ctyp<>> -> None + | t -> Some (ctyp t) ] in + mkexp loc (Pexp_constraint (expr e) t1 (Some (ctyp t2))) + | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) + | ExFor loc i e1 e2 df el -> + let e3 = ExSeq loc el in + mkexp loc (Pexp_for i (expr e1) (expr e2) (mkdirection df) (expr e3)) + | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> + mkexp loc + (Pexp_function lab None + [(patt_of_lab loc lab po, when_expr e w)]) + | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> + let lab = paolab lab p in + mkexp loc + (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)]) + | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> + let lab = paolab lab p in + mkexp loc + (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)]) + | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a [])) + | ExIfe loc e1 e2 e3 -> + mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) + | ExInt loc s -> + let i = try int_of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" + ] in mkexp loc (Pexp_constant (Const_int i)) + | ExInt32 loc s -> + let i32 = try Int32.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" + ] in mkexp loc (Pexp_constant (Const_int32 i32)) + | ExInt64 loc s -> + let i64 = try Int64.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" + ] in mkexp loc (Pexp_constant (Const_int64 i64)) + | ExNativeInt loc s -> + let nati = try Nativeint.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" + ] in mkexp loc (Pexp_constant (Const_nativeint nati)) + | ExLab loc _ _ -> error loc "labeled expression not allowed here" + | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) + | ExLet loc rf bi e -> + mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) + | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) + | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) + | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) + | ExObj loc po cfl -> + let p = + match po with + [ <:patt<>> -> <:patt@loc< _ >> + | p -> p ] + in + let cil = class_str_item cfl [] in + mkexp loc (Pexp_object (patt p, cil)) + | ExOlb loc _ _ -> error loc "labeled expression not allowed here" + | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel [])) + | ExRec loc lel eo -> + match lel with + [ <:rec_binding<>> -> error loc "empty record" + | _ -> + let eo = + match eo with + [ <:expr<>> -> None + | e -> Some (expr e) ] in + mkexp loc (Pexp_record (mklabexp lel []) eo) ] + | ExSeq _loc e -> + let rec loop = + fun + [ [] -> expr <:expr< () >> + | [e] -> expr e + | [e :: el] -> + let _loc = Loc.merge (loc_of_expr e) _loc in + mkexp _loc (Pexp_sequence (expr e) (loop el)) ] + in + loop (list_of_expr e []) + | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) + | ExSte loc e1 e2 -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) + [("", expr e1); ("", expr e2)]) + | ExStr loc s -> + mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) + | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) + | <:expr@loc< ($e1$, $e2$) >> -> + mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) + | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" + | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) + | <:expr@loc< () >> -> + mkexp loc (Pexp_construct (lident "()") None True) + | <:expr@loc< $lid:s$ >> -> + mkexp loc (Pexp_ident (lident s)) + | <:expr@loc< $uid:s$ >> -> + (* let ca = constructors_arity () in *) + mkexp loc (Pexp_construct (lident (conv_con s)) None True) + | ExVrn loc s -> mkexp loc (Pexp_variant s None) + | ExWhi loc e1 el -> + let e2 = ExSeq loc el in + mkexp loc (Pexp_while (expr e1) (expr e2)) + | <:expr@loc< let open $i$ in $e$ >> -> + mkexp loc (Pexp_open (long_uident i) (expr e)) + | <:expr@loc< (module $me$ : $pt$) >> -> + mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), + Some (mktyp loc (Ptyp_package (package_type pt))), None)) + | <:expr@loc< (module $me$) >> -> + mkexp loc (Pexp_pack (module_expr me)) + | ExFUN loc i e -> + mkexp loc (Pexp_newtype i (expr e)) + | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" + | <:expr@loc< $_$;$_$ >> -> + error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" + | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ] + and patt_of_lab _loc lab = + fun + [ <:patt<>> -> patt <:patt< $lid:lab$ >> + | p -> patt p ] + and expr_of_lab _loc lab = + fun + [ <:expr<>> -> expr <:expr< $lid:lab$ >> + | e -> expr e ] + and label_expr = + fun + [ ExLab loc lab eo -> (lab, expr_of_lab loc lab eo) + | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo) + | e -> ("", expr e) ] + and binding x acc = + match x with + [ <:binding< $x$ and $y$ >> -> + binding x (binding y acc) + | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> + [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc] + | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc] + | <:binding<>> -> acc + | _ -> assert False ] + and match_case x acc = + match x with + [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc) + | <:match_case< $pat:p$ when $w$ -> $e$ >> -> + [(patt p, when_expr e w) :: acc] + | <:match_case<>> -> acc + | _ -> assert False ] + and when_expr e w = + match w with + [ <:expr<>> -> expr e + | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ] + and mklabexp x acc = + match x with + [ <:rec_binding< $x$; $y$ >> -> + mklabexp x (mklabexp y acc) + | <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] + | _ -> assert False ] + and mkideexp x acc = + match x with + [ <:rec_binding<>> -> acc + | <:rec_binding< $x$; $y$ >> -> + mkideexp x (mkideexp y acc) + | <:rec_binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc] + | _ -> assert False ] + and mktype_decl x acc = + match x with + [ <:ctyp< $x$ and $y$ >> -> + mktype_decl x (mktype_decl y acc) + | Ast.TyDcl _ c tl td cl -> + let cl = + List.map + (fun (t1, t2) -> + let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in + (ctyp t1, ctyp t2, mkloc loc)) + cl + in + [(c, type_decl (List.fold_right type_parameters tl []) cl td) :: acc] + | _ -> assert False ] + and module_type = + fun + [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" + | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) + | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> + mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) + | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" + | <:module_type@loc< sig $sl$ end >> -> + mkmty loc (Pmty_signature (sig_item sl [])) + | <:module_type@loc< $mt$ with $wc$ >> -> + mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) + | <:module_type< $anti:_$ >> -> assert False ] + and sig_item s l = + match s with + [ <:sig_item<>> -> l + | SgCls loc cd -> + [mksig loc (Psig_class + (List.map class_info_class_type (list_of_class_type cd []))) :: l] + | SgClt loc ctd -> + [mksig loc (Psig_class_type + (List.map class_info_class_type (list_of_class_type ctd []))) :: l] + | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) + | SgDir _ _ _ -> l + | <:sig_item@loc< exception $uid:s$ >> -> + [mksig loc (Psig_exception (conv_con s) []) :: l] + | <:sig_item@loc< exception $uid:s$ of $t$ >> -> + [mksig loc (Psig_exception (conv_con s) + (List.map ctyp (list_of_ctyp t []))) :: l] + | SgExc _ _ -> assert False (*FIXME*) + | SgExt loc n t sl -> [mksig loc (Psig_value n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] + | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] + | SgRecMod loc mb -> + [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] + | SgMty loc n mt -> + let si = + match mt with + [ MtQuo _ _ -> Pmodtype_abstract + | _ -> Pmodtype_manifest (module_type mt) ] + in + [mksig loc (Psig_modtype n si) :: l] + | SgOpn loc id -> + [mksig loc (Psig_open (long_uident id)) :: l] + | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] + | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] + | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] + and module_sig_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + module_sig_binding x (module_sig_binding y acc) + | <:module_binding< $s$ : $mt$ >> -> + [(s, module_type mt) :: acc] + | _ -> assert False ] + and module_str_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + module_str_binding x (module_str_binding y acc) + | <:module_binding< $s$ : $mt$ = $me$ >> -> + [(s, module_type mt, module_expr me) :: acc] + | _ -> assert False ] + and module_expr = + fun + [ <:module_expr@loc<>> -> error loc "nil module expression" + | <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i)) + | <:module_expr@loc< $me1$ $me2$ >> -> + mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) + | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> + mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) + | <:module_expr@loc< struct $sl$ end >> -> + mkmod loc (Pmod_structure (str_item sl [])) + | <:module_expr@loc< ($me$ : $mt$) >> -> + mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) + | <:module_expr@loc< (value $e$ : $pt$) >> -> + mkmod loc (Pmod_unpack ( + mkexp loc (Pexp_constraint (expr e, + Some (mktyp loc (Ptyp_package (package_type pt))), + None)))) + | <:module_expr@loc< (value $e$) >> -> + mkmod loc (Pmod_unpack (expr e)) + | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] + and str_item s l = + match s with + [ <:str_item<>> -> l + | StCls loc cd -> + [mkstr loc (Pstr_class + (List.map class_info_class_expr (list_of_class_expr cd []))) :: l] + | StClt loc ctd -> + [mkstr loc (Pstr_class_type + (List.map class_info_class_type (list_of_class_type ctd []))) :: l] + | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) + | StDir _ _ _ -> l + | <:str_item@loc< exception $uid:s$ >> -> + [mkstr loc (Pstr_exception (conv_con s) []) :: l ] + | <:str_item@loc< exception $uid:s$ of $t$ >> -> + [mkstr loc (Pstr_exception (conv_con s) + (List.map ctyp (list_of_ctyp t []))) :: l ] + | <:str_item@loc< exception $uid:s$ = $i$ >> -> + [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ] + | StExc _ _ _ -> assert False (*FIXME*) + | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] + | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] + | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] + | StRecMod loc mb -> + [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] + | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] + | StOpn loc id -> + [mkstr loc (Pstr_open (long_uident id)) :: l] + | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] + | StVal loc rf bi -> + [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] + | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] + and class_type = + fun + [ CtCon loc ViNil id tl -> + mkcty loc + (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) + | CtFun loc (TyLab _ lab t) ct -> + mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) + | CtFun loc (TyOlb loc1 lab t) ct -> + let t = TyApp loc1 <:ctyp@loc1< option >> t in + mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) + | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) + | CtSig loc t_o ctfl -> + let t = + match t_o with + [ <:ctyp<>> -> <:ctyp@loc< _ >> + | t -> t ] + in + let cil = class_sig_item ctfl [] in + mkcty loc (Pcty_signature (ctyp t, cil)) + | CtCon loc _ _ _ -> + error loc "invalid virtual class inside a class type" + | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> + assert False ] + + and class_info_class_expr ci = + match ci with + [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce -> + let (loc_params, (params, variance)) = + match params with + [ <:ctyp<>> -> (loc, ([], [])) + | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] + in + {pci_virt = mkvirtual vir; + pci_params = (params, mkloc loc_params); + pci_name = name; + pci_expr = class_expr ce; + pci_loc = mkloc loc; + pci_variance = variance} + | ce -> error (loc_of_class_expr ce) "bad class definition" ] + and class_info_class_type ci = + match ci with + [ CtEq _ (CtCon loc vir (IdLid _ name) params) ct | + CtCol _ (CtCon loc vir (IdLid _ name) params) ct -> + let (loc_params, (params, variance)) = + match params with + [ <:ctyp<>> -> (loc, ([], [])) + | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] + in + {pci_virt = mkvirtual vir; + pci_params = (params, mkloc loc_params); + pci_name = name; + pci_expr = class_type ct; + pci_loc = mkloc loc; + pci_variance = variance} + | ct -> error (loc_of_class_type ct) + "bad class/class type declaration/definition" ] + and class_sig_item c l = + match c with + [ <:class_sig_item<>> -> l + | CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | <:class_sig_item< $csg1$; $csg2$ >> -> + class_sig_item csg1 (class_sig_item csg2 l) + | CgInh _ ct -> [Pctf_inher (class_type ct) :: l] + | CgMth loc s pf t -> + [Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l] + | CgVal loc s b v t -> + [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l] + | CgVir loc s b t -> + [Pctf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l] + | CgAnt _ _ -> assert False ] + and class_expr = + fun + [ CeApp loc _ _ as c -> + let (ce, el) = class_expr_fa [] c in + let el = List.map label_expr el in + mkpcl loc (Pcl_apply (class_expr ce) el) + | CeCon loc ViNil id tl -> + mkpcl loc + (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) + | CeFun loc (PaLab _ lab po) ce -> + mkpcl loc + (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) + | CeFun loc (PaOlbi _ lab p e) ce -> + let lab = paolab lab p in + mkpcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) + | CeFun loc (PaOlb _ lab p) ce -> + let lab = paolab lab p in + mkpcl loc + (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) + | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) + | CeLet loc rf bi ce -> + mkpcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) + | CeStr loc po cfl -> + let p = + match po with + [ <:patt<>> -> <:patt@loc< _ >> + | p -> p ] + in + let cil = class_str_item cfl [] in + mkpcl loc (Pcl_structure (patt p, cil)) + | CeTyc loc ce ct -> + mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) + | CeCon loc _ _ _ -> + error loc "invalid virtual class inside a class expression" + | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] + and class_str_item c l = + match c with + [ CrNil _ -> l + | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | <:class_str_item< $cst1$; $cst2$ >> -> + class_str_item cst1 (class_str_item cst2 l) + | CrInh loc ov ce pb -> + let opb = if pb = "" then None else Some pb in + [Pcf_inher (override_flag loc ov) (class_expr ce) opb :: l] + | CrIni _ e -> [Pcf_init (expr e) :: l] + | CrMth loc s ov pf e t -> + let t = + match t with + [ <:ctyp<>> -> None + | t -> Some (mkpolytype (ctyp t)) ] in + let e = mkexp loc (Pexp_poly (expr e) t) in + [Pcf_meth (s, mkprivate pf, override_flag loc ov, e, mkloc loc) :: l] + | CrVal loc s ov mf e -> + [Pcf_val (s, mkmutable mf, override_flag loc ov, expr e, mkloc loc) :: l] + | CrVir loc s pf t -> + [Pcf_virt (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l] + | CrVvr loc s mf t -> + [Pcf_valvirt (s, mkmutable mf, ctyp t, mkloc loc) :: l] + | CrAnt _ _ -> assert False ]; + + value sig_item ast = sig_item ast []; + value str_item ast = str_item ast []; + + value directive = + fun + [ <:expr<>> -> Pdir_none + | ExStr _ s -> Pdir_string s + | ExInt _ i -> Pdir_int (int_of_string i) + | <:expr< True >> -> Pdir_bool True + | <:expr< False >> -> Pdir_bool False + | e -> Pdir_ident (ident (ident_of_expr e)) ] + ; + + value phrase = + fun + [ StDir _ d dp -> Ptop_dir d (directive dp) + | si -> Ptop_def (str_item si) ] + ; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli new file mode 100644 index 0000000000..6c28483323 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -0,0 +1,32 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-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 (Camlp4Ast : Sig.Camlp4Ast) : sig + open Camlp4Ast; + + (** {6 Useful functions} *) + + value sig_item : sig_item -> Camlp4_import.Parsetree.signature; + value str_item : str_item -> Camlp4_import.Parsetree.structure; + value phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/CleanAst.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/CleanAst.ml new file mode 100644 index 0000000000..ab9250543c --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/CleanAst.ml @@ -0,0 +1,145 @@ +(****************************************************************************) +(* *) +(* 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: + * - Nicolas Pouillard: initial version + *) + +(** This module is suppose to contain nils elimination. *) +module Make (Ast : Sig.Camlp4Ast) = struct + + class clean_ast = object + + inherit Ast.map as super; + + method with_constr wc = + match super#with_constr wc with + [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | + <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc + | wc -> wc ]; + + method expr e = + match super#expr e with + [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | + <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | + <:expr< $ <:expr<>> $, $e$ >> | + <:expr< $e$, $ <:expr<>> $ >> | + <:expr< $ <:expr<>> $; $e$ >> | + <:expr< $e$; $ <:expr<>> $ >> -> e + | e -> e ]; + + method patt p = + match super#patt p with + [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | + <:patt< $ <:patt<>> $ | $p$ >> | + <:patt< $p$ | $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $, $p$ >> | + <:patt< $p$, $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $; $p$ >> | + <:patt< $p$; $ <:patt<>> $ >> -> p + | p -> p ]; + + method match_case mc = + match super#match_case mc with + [ <:match_case< $ <:match_case<>> $ | $mc$ >> | + <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc + | mc -> mc ]; + + method binding bi = + match super#binding bi with + [ <:binding< $ <:binding<>> $ and $bi$ >> | + <:binding< $bi$ and $ <:binding<>> $ >> -> bi + | bi -> bi ]; + + method rec_binding rb = + match super#rec_binding rb with + [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | + <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi + | bi -> bi ]; + + method module_binding mb = + match super#module_binding mb with + [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | + <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb + | mb -> mb ]; + + method ctyp t = + match super#ctyp t with + [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | + <:ctyp< $ <:ctyp<>> $ as $t$ >> | + <:ctyp< $t$ as $ <:ctyp<>> $ >> | + <:ctyp< $t$ -> $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ -> $t$ >> | + <:ctyp< $ <:ctyp<>> $ | $t$ >> | + <:ctyp< $t$ | $ <:ctyp<>> $ >> | + <:ctyp< $t$ of $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ and $t$ >> | + <:ctyp< $t$ and $ <:ctyp<>> $ >> | + <:ctyp< $t$; $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $; $t$ >> | + <:ctyp< $ <:ctyp<>> $, $t$ >> | + <:ctyp< $t$, $ <:ctyp<>> $ >> | + <:ctyp< $t$ & $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ & $t$ >> | + <:ctyp< $ <:ctyp<>> $ * $t$ >> | + <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t + | t -> t ]; + + method sig_item sg = + match super#sig_item sg with + [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | + <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg + | <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>> + | sg -> sg ]; + + method str_item st = + match super#str_item st with + [ <:str_item< $ <:str_item<>> $; $st$ >> | + <:str_item< $st$; $ <:str_item<>> $ >> -> st + | <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>> + | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>> + | st -> st ]; + + method module_type mt = + match super#module_type mt with + [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt + | mt -> mt ]; + + method class_expr ce = + match super#class_expr ce with + [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | + <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce + | ce -> ce ]; + + method class_type ct = + match super#class_type ct with + [ <:class_type< $ <:class_type<>> $ and $ct$ >> | + <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct + | ct -> ct ]; + + method class_sig_item csg = + match super#class_sig_item csg with + [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | + <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg + | csg -> csg ]; + + method class_str_item cst = + match super#class_str_item cst with + [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | + <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst + | cst -> cst ]; + + end; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.ml new file mode 100644 index 0000000000..9dac53fbf7 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.ml @@ -0,0 +1,56 @@ +(****************************************************************************) +(* *) +(* 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 (Token : Sig.Camlp4Token) = struct + open Token; + + type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t)); + + value mk () = + let q = Queue.create () in + let f _ = + debug comments "take...@\n" in + try Some (Queue.take q) with [ Queue.Empty -> None ] + in (Stream.from f, q); + + value filter (_, q) = + let rec self = + parser + [ [: ` (Sig.COMMENT x, loc); xs :] -> + do { Queue.add (x, loc) q; + debug comments "add: %S at %a@\n" x Loc.dump loc in + self xs } + | [: ` x; xs :] -> + (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) + [: ` x; self xs :] + | [: :] -> [: :] ] + in self; + + value take_list (_, q) = + let rec self accu = + if Queue.is_empty q then accu else self [Queue.take q :: accu] + in self []; + + value take_stream = fst; + + value define token_fiter comments_strm = + debug comments "Define a comment filter@\n" in + Token.Filter.define_filter token_fiter + (fun previous strm -> previous (filter comments_strm strm)); + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.mli new file mode 100644 index 0000000000..79ece6a4c7 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/CommentFilter.mli @@ -0,0 +1,33 @@ +(****************************************************************************) +(* *) +(* 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 (Token : Sig.Camlp4Token) : sig + open Token; + + type t; + + value mk : unit -> t; + + value define : Token.Filter.t -> t -> unit; + + value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t); + + value take_list : t -> list (string * Loc.t); + + value take_stream : t -> Stream.t (string * Loc.t); +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/DynAst.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynAst.ml new file mode 100644 index 0000000000..2161e1c91c --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynAst.ml @@ -0,0 +1,91 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 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: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct + module Ast = Ast; + type tag 'a = + [ Tag_ctyp + | Tag_patt + | Tag_expr + | Tag_module_type + | Tag_sig_item + | Tag_with_constr + | Tag_module_expr + | Tag_str_item + | Tag_class_type + | Tag_class_sig_item + | Tag_class_expr + | Tag_class_str_item + | Tag_match_case + | Tag_ident + | Tag_binding + | Tag_rec_binding + | Tag_module_binding ]; + + value string_of_tag = + fun + [ Tag_ctyp -> "ctyp" + | Tag_patt -> "patt" + | Tag_expr -> "expr" + | Tag_module_type -> "module_type" + | Tag_sig_item -> "sig_item" + | Tag_with_constr -> "with_constr" + | Tag_module_expr -> "module_expr" + | Tag_str_item -> "str_item" + | Tag_class_type -> "class_type" + | Tag_class_sig_item -> "class_sig_item" + | Tag_class_expr -> "class_expr" + | Tag_class_str_item -> "class_str_item" + | Tag_match_case -> "match_case" + | Tag_ident -> "ident" + | Tag_binding -> "binding" + | Tag_rec_binding -> "rec_binding" + | Tag_module_binding -> "module_binding" ]; + + value ctyp_tag = Tag_ctyp; + value patt_tag = Tag_patt; + value expr_tag = Tag_expr; + value module_type_tag = Tag_module_type; + value sig_item_tag = Tag_sig_item; + value with_constr_tag = Tag_with_constr; + value module_expr_tag = Tag_module_expr; + value str_item_tag = Tag_str_item; + value class_type_tag = Tag_class_type; + value class_sig_item_tag = Tag_class_sig_item; + value class_expr_tag = Tag_class_expr; + value class_str_item_tag = Tag_class_str_item; + value match_case_tag = Tag_match_case; + value ident_tag = Tag_ident; + value binding_tag = Tag_binding; + value rec_binding_tag = Tag_rec_binding; + value module_binding_tag = Tag_module_binding; + + type dyn; + external dyn_tag : tag 'a -> tag dyn = "%identity"; + + module Pack(X : sig type t 'a; end) = struct + (* These Obj.* hacks should be avoided with GADTs *) + type pack = (tag dyn * Obj.t); + exception Pack_error; + value pack tag v = (dyn_tag tag, Obj.repr v); + value unpack (tag : tag 'a) (tag', obj) = + if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error; + value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag); + end; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.ml new file mode 100644 index 0000000000..f8e8c22fdf --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.ml @@ -0,0 +1,84 @@ +(* camlp4r pa_macro.cmo *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2001-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 + *) + + + + +type t = Queue.t string; + +exception Error of string and string; + +value include_dir x y = Queue.add y x; + +value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x; + +value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () = + let q = Queue.create () in do { + if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); + if camlp4_stdlib then do { + include_dir q Camlp4_config.camlp4_standard_library; + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters"); + } else (); + include_dir q "."; + q +}; + +(* Load files in core *) + +value find_in_path x name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else + let res = + fold_load_path x + (fun dir -> + fun + [ None -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then Some fullname else None + | x -> x ]) None + in match res with [ None -> raise Not_found | Some x -> x ]; + +value load = + let _initialized = ref False in + fun _path file -> + do { + if not _initialized.val then + try do { + Dynlink.init (); + Dynlink.allow_unsafe_modules True; + _initialized.val := True + } + with + [ Dynlink.Error e -> + raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ] + else (); + let fname = + try find_in_path _path file with + [ Not_found -> raise (Error file "file not found in path") ] + in + try Dynlink.loadfile fname with + [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] + }; + + +value is_native = Dynlink.is_native; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.mli new file mode 100644 index 0000000000..292b705b57 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/DynLoader.mli @@ -0,0 +1,20 @@ +(****************************************************************************) +(* *) +(* 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 + *) + +include Sig.DynLoader; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.ml new file mode 100644 index 0000000000..1acb2251a9 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.ml @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* 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 + *) +type t = unit; +exception E of t; +value print _ = assert False; +value to_string _ = assert False;
\ No newline at end of file diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.mli new file mode 100644 index 0000000000..9d216623a4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyError.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* 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 + *) +include Sig.Error;
\ No newline at end of file diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.ml new file mode 100644 index 0000000000..5886809b6b --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.ml @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* 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: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) = struct + value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; + value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.mli new file mode 100644 index 0000000000..f8bf907ae5 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/EmptyPrinter.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-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: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.ml new file mode 100644 index 0000000000..69e9030367 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.ml @@ -0,0 +1,127 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* 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: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) = struct + + module S = Set.Make String; + + class c_fold_pattern_vars ['accu] f init = + object + inherit Ast.fold as super; + value acc = init; + method acc : 'accu = acc; + method patt = + fun + [ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> -> + {< acc = f s acc >} + | p -> super#patt p ]; + end; + + value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; + + value rec fold_binding_vars f bi acc = + match bi with + [ <:binding< $bi1$ and $bi2$ >> -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc + | <:binding<>> -> acc + | <:binding< $anti:_$ >> -> assert False ]; + + class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = + object (o) + inherit Ast.fold as super; + value free : 'accu = free_init; + value env : S.t = env_init; + + method free = free; + method set_env env = {< env = env >}; + method add_atom s = {< env = S.add s env >}; + method add_patt p = {< env = fold_pattern_vars S.add p env >}; + method add_binding bi = {< env = fold_binding_vars S.add bi env >}; + + method expr = + fun + [ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> -> + if S.mem s env then o else {< free = f s free >} + + | <:expr< let $bi$ in $e$ >> -> + (((o#add_binding bi)#expr e)#set_env env)#binding bi + + | <:expr< let rec $bi$ in $e$ >> -> + (((o#add_binding bi)#expr e)#binding bi)#set_env env + + | <:expr< for $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> + ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env + + | <:expr< $id:_$ >> | <:expr< new $_$ >> -> o + + | <:expr< object ($p$) $cst$ end >> -> + ((o#add_patt p)#class_str_item cst)#set_env env + + | e -> super#expr e ]; + + method match_case = + fun + [ <:match_case< $p$ when $e1$ -> $e2$ >> -> + (((o#add_patt p)#expr e1)#expr e2)#set_env env + | m -> super#match_case m ]; + + method str_item = + fun + [ <:str_item< external $s$ : $t$ = $_$ >> -> + (o#ctyp t)#add_atom s + | <:str_item< value $bi$ >> -> + (o#binding bi)#add_binding bi + | <:str_item< value rec $bi$ >> -> + (o#add_binding bi)#binding bi + | st -> super#str_item st ]; + + method class_expr = + fun + [ <:class_expr< fun $p$ -> $ce$ >> -> + ((o#add_patt p)#class_expr ce)#set_env env + | <:class_expr< let $bi$ in $ce$ >> -> + (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env + | <:class_expr< let rec $bi$ in $ce$ >> -> + (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env + | <:class_expr< object ($p$) $cst$ end >> -> + ((o#add_patt p)#class_str_item cst)#set_env env + | ce -> super#class_expr ce ]; + + method class_str_item = + fun + [ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst + | <:class_str_item< inherit $override:_$ $ce$ as $s$ >> -> + (o#class_expr ce)#add_atom s + | <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> -> + (o#expr e)#add_atom s + | <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> -> + (o#ctyp t)#add_atom s + | cst -> super#class_str_item cst ]; + + method module_expr = fun + [ <:module_expr< struct $st$ end >> -> + (o#str_item st)#set_env env + | me -> super#module_expr me ]; + + end; + + value free_vars env_init e = + let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.mli new file mode 100644 index 0000000000..aac72db054 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/FreeVars.mli @@ -0,0 +1,48 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* 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: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) : sig + module S : Set.S with type elt = string; + + value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu; + + class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] -> + object + inherit Ast.fold; + value acc : 'accu; + method acc : 'accu; + end; + + value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu; + + class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] -> + object ('self_type) + inherit Ast.fold; + value free : 'accu; + value env : S.t; + method free : 'accu; + method set_env : S.t -> 'self_type; + method add_atom : string -> 'self_type; + method add_patt : Ast.patt -> 'self_type; + method add_binding : Ast.binding -> 'self_type; + end; + + value free_vars : S.t -> Ast.expr -> S.t; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar.mlpack b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar.mlpack new file mode 100644 index 0000000000..46fb34f74b --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar.mlpack @@ -0,0 +1,13 @@ +Delete +Dynamic +Entry +Failed +Find +Fold +Insert +Parser +Print +Search +Static +Structure +Tools diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Delete.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Delete.ml new file mode 100644 index 0000000000..929ac2b4ea --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Delete.ml @@ -0,0 +1,161 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Parser = Parser.Make Structure; + open Structure; + +(* Deleting a rule *) + +(* [delete_rule_in_tree] returns + [Some (dsl, t)] if success + [dsl] = + Some (list of deleted nodes) if branch deleted + None if action replaced by previous version of action + [t] = remaining tree + [None] if failure *) + +value delete_rule_in_tree entry = + let rec delete_in_tree symbols tree = + match (symbols, tree) with + [ ([s :: sl], Node n) -> + if Tools.logically_eq_symbols entry s n.node then delete_son sl n + else + match delete_in_tree symbols n.brother with + [ Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None ] + | ([_ :: _], _) -> None + | ([], Node n) -> + match delete_in_tree [] n.brother with + [ Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None ] + | ([], DeadEnd) -> None + | ([], LocAct _ []) -> Some (Some [], DeadEnd) + | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] + and delete_son sl n = + match delete_in_tree sl n.son with + [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) + | Some (Some dsl, t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (Some [n.node :: dsl], t) + | Some (None, t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (None, t) + | None -> None ] + in + delete_in_tree +; +value rec decr_keyw_use gram = + fun + [ Skeyword kwd -> removing gram kwd + | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl + | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s + | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } + | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } + | Stree t -> decr_keyw_use_in_tree gram t + | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ] +and decr_keyw_use_in_tree gram = + fun + [ DeadEnd | LocAct _ _ -> () + | Node n -> + do { + decr_keyw_use gram n.node; + decr_keyw_use_in_tree gram n.son; + decr_keyw_use_in_tree gram n.brother + } ] +; +value rec delete_rule_in_suffix entry symbols = + fun + [ [lev :: levs] -> + match delete_rule_in_tree entry symbols lev.lsuffix with + [ Some (dsl, t) -> + do { + match dsl with + [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl + | None -> () ]; + match t with + [ DeadEnd when lev.lprefix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; lsuffix = t; + lprefix = lev.lprefix} + in + [lev :: levs] ] + } + | None -> + let levs = delete_rule_in_suffix entry symbols levs in + [lev :: levs] ] + | [] -> raise Not_found ] +; + +value rec delete_rule_in_prefix entry symbols = + fun + [ [lev :: levs] -> + match delete_rule_in_tree entry symbols lev.lprefix with + [ Some (dsl, t) -> + do { + match dsl with + [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl + | None -> () ]; + match t with + [ DeadEnd when lev.lsuffix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; + lsuffix = lev.lsuffix; lprefix = t} + in + [lev :: levs] ] + } + | None -> + let levs = delete_rule_in_prefix entry symbols levs in + [lev :: levs] ] + | [] -> raise Not_found ] +; + +value rec delete_rule_in_level_list entry symbols levs = + match symbols with + [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs + | [Snterm e :: symbols] when e == entry -> + delete_rule_in_suffix entry symbols levs + | _ -> delete_rule_in_prefix entry symbols levs ] +; + + +value delete_rule entry sl = + match entry.edesc with + [ Dlevels levs -> + let levs = delete_rule_in_level_list entry sl levs in + do { + entry.edesc := Dlevels levs; + entry.estart := + fun lev strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev strm }; + entry.econtinue := + fun lev bp a strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a strm } + } + | Dparser _ -> () ] +; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Dynamic.ml new file mode 100644 index 0000000000..7889cf0712 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Dynamic.ml @@ -0,0 +1,73 @@ +(****************************************************************************) +(* *) +(* 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 (Lexer : Sig.Lexer) +: Sig.Grammar.Dynamic with module Loc = Lexer.Loc + and module Token = Lexer.Token += struct + module Structure = Structure.Make Lexer; + module Delete = Delete.Make Structure; + module Insert = Insert.Make Structure; + module Entry = Entry.Make Structure; + module Fold = Fold.Make Structure; + module Tools = Tools.Make Structure; + include Structure; + + value mk () = + let gkeywords = Hashtbl.create 301 in + { + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref True; (* FIXME *) + error_verbose = Camlp4_config.verbose + }; + + value get_filter g = g.gfilter; + + value lex g loc cs = g.glexer loc cs; + + value lex_string g loc str = lex g loc (Stream.of_string str); + + value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts); + + value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts; + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs); + + value parse_string entry loc str = + parse_tokens_before_filter entry (lex_string entry.egram loc str); + + value delete_rule = Delete.delete_rule; + + value srules e rl = + let t = + List.fold_left + (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) + DeadEnd rl + in + Stree t; + value sfold0 = Fold.sfold0; + value sfold1 = Fold.sfold1; + value sfold0sep = Fold.sfold0sep; + (* value sfold1sep = Fold.sfold1sep; *) + + value extend = Insert.extend; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Entry.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Entry.ml new file mode 100644 index 0000000000..0b39b7ca6c --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Entry.ml @@ -0,0 +1,92 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + module Dump = Print.MakeDump Structure; + module Print = Print.Make Structure; + module Tools = Tools.Make Structure; + open Format; + open Structure; + open Tools; + + type t 'a = internal_entry; + + value name e = e.ename; + + value print ppf e = fprintf ppf "%a@\n" Print.entry e; + value dump ppf e = fprintf ppf "%a@\n" Dump.entry e; + + (* value find e s = Find.entry e s; *) + + value mk g n = + { egram = g; + ename = n; + estart = empty_entry n; + econtinue _ _ _ = parser []; + edesc = Dlevels [] }; + + value action_parse entry ts : Action.t = + try entry.estart 0 ts with + [ Stream.Failure -> + Loc.raise (get_prev_loc ts) + (Stream.Error ("illegal begin of " ^ entry.ename)) + | Loc.Exc_located _ _ as exc -> raise exc + | exc -> Loc.raise (get_prev_loc ts) exc ]; + + value lex entry loc cs = entry.egram.glexer loc cs; + + value lex_string entry loc str = lex entry loc (Stream.of_string str); + + value filter entry ts = + keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts); + + value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts); + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs); + + value parse_string entry loc str = + parse_tokens_before_filter entry (lex_string entry loc str); + + value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a = + let f ts = Action.mk (p ts) in + { egram = g; + ename = n; + estart _ = f; + econtinue _ _ _ = parser []; + edesc = Dparser f }; + + value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) = + let f ts = Action.mk (p ts) in do { + e.estart := fun _ -> f; + e.econtinue := fun _ _ _ -> parser []; + e.edesc := Dparser f + }; + + value clear e = + do { + e.estart := fun _ -> parser []; + e.econtinue := fun _ _ _ -> parser []; + e.edesc := Dlevels [] + }; + + value obj x = x; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Failed.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Failed.ml new file mode 100644 index 0000000000..b22998bd48 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Failed.ml @@ -0,0 +1,132 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Search = Search.Make Structure; + module Print = Print.Make Structure; + open Structure; + open Format; + +value rec name_of_symbol entry = + fun + [ Snterm e -> "[" ^ e.ename ^ "]" + | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" + | Sself | Snext -> "[" ^ entry.ename ^ "]" + | Stoken (_, descr) -> descr + | Skeyword kwd -> "\"" ^ kwd ^ "\"" + | _ -> "???" ] +; + + +value rec name_of_symbol_failed entry = + fun + [ Slist0 s | Slist0sep s _ | + Slist1 s | Slist1sep s _ | + Sopt s | Stry s -> name_of_symbol_failed entry s + | Stree t -> name_of_tree_failed entry t + | s -> name_of_symbol entry s ] +and name_of_tree_failed entry = + fun + [ Node {node = s; brother = bro; son = son} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let txt = name_of_symbol_failed entry s in + let txt = + match (s, son) with + [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son + | _ -> txt ] + in + let txt = + match bro with + [ DeadEnd | LocAct _ _ -> txt + | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] + in + txt + | Some (tokl, _, _) -> + List.fold_left + (fun s tok -> + (if s = "" then "" else s ^ " then ") ^ + match tok with + [ Stoken (_, descr) -> descr + | Skeyword kwd -> kwd + | _ -> assert False ]) + "" tokl ] + | DeadEnd | LocAct _ _ -> "???" ] +; +value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x; +value tree_failed entry prev_symb_result prev_symb tree = + let txt = name_of_tree_failed entry tree in + let txt = + match prev_symb with + [ Slist0 s -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | Slist1 s -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | Slist0sep s sep -> + match magic "tree_failed: 'a -> list 'b" prev_symb_result with + [ [] -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | _ -> + let txt1 = name_of_symbol_failed entry sep in + txt1 ^ " or " ^ txt ^ " expected" ] + | Slist1sep s sep -> + match magic "tree_failed: 'a -> list 'b" prev_symb_result with + [ [] -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | _ -> + let txt1 = name_of_symbol_failed entry sep in + txt1 ^ " or " ^ txt ^ " expected" ] + | Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected" + | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] + in + do { + if entry.egram.error_verbose.val then do { + let tree = Search.tree_in_entry prev_symb tree entry.edesc; + let ppf = err_formatter; + fprintf ppf "@[<v 0>@,"; + fprintf ppf "----------------------------------@,"; + fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; + fprintf ppf "@["; + Print.print_level ppf pp_force_newline (Print.flatten_tree tree); + fprintf ppf "@]@,"; + fprintf ppf "----------------------------------@,"; + fprintf ppf "@]@." + } + else (); + txt ^ " (in [" ^ entry.ename ^ "])" + } +; +value symb_failed entry prev_symb_result prev_symb symb = + let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in + tree_failed entry prev_symb_result prev_symb tree +; + +value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Find.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Find.ml new file mode 100644 index 0000000000..9e7774d152 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Find.ml @@ -0,0 +1,68 @@ +(****************************************************************************) +(* *) +(* 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 + *) +(* + value entry e s = + let rec find_levels = + fun + [ [] -> None + | [lev :: levs] -> + match find_tree lev.lsuffix with + [ None -> + match find_tree lev.lprefix with + [ None -> find_levels levs + | x -> x ] + | x -> x ] ] + and symbol = + fun + [ Snterm e -> if e.ename = s then Some e else None + | Snterml e _ -> if e.ename = s then Some e else None + | Smeta _ sl _ -> find_symbol_list sl + | Slist0 s -> find_symbol s + | Slist0sep s _ -> find_symbol s + | Slist1 s -> find_symbol s + | Slist1sep s _ -> find_symbol s + | Sopt s -> find_symbol s + | Stree t -> find_tree t + | Sself | Snext | Stoken _ | Stoken_fun _ -> None ] + and symbol_list = + fun + [ [s :: sl] -> + match find_symbol s with + [ None -> find_symbol_list sl + | x -> x ] + | [] -> None ] + and tree = + fun + [ Node {node = s; brother = bro; son = son} -> + match find_symbol s with + [ None -> + match find_tree bro with + [ None -> find_tree son + | x -> x ] + | x -> x ] + | LocAct _ _ | DeadEnd -> None ] + in + match e.edesc with + [ Dlevels levs -> + match find_levels levs with + [ Some e -> e + | None -> raise Not_found ] + | Dparser _ -> raise Not_found ] + ; +*) diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.ml new file mode 100644 index 0000000000..caf8a7a0a3 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.ml @@ -0,0 +1,95 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + open Structure; + open Format; + module Parse = Parser.Make Structure; + module Fail = Failed.Make Structure; + open Sig.Grammar; + + (* Prevent from implict usage. *) + module Stream = struct + type t 'a = Stream.t 'a; + exception Failure = Stream.Failure; + exception Error = Stream.Error; + end; + + value sfold0 f e _entry _symbl psymb = + let rec fold accu = + parser + [ [: a = psymb; s :] -> fold (f a accu) s + | [: :] -> accu ] + in + parser [: a = fold e :] -> a + ; + + value sfold1 f e _entry _symbl psymb = + let rec fold accu = + parser + [ [: a = psymb; s :] -> fold (f a accu) s + | [: :] -> accu ] + in + parser [: a = psymb; a = fold (f a e) :] -> a + ; + + value sfold0sep f e entry symbl psymb psep = + let failed = + fun + [ [symb; sep] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" ] + in + let rec kont accu = + parser + [ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s + | [: :] -> accu ] + in + parser + [ [: a = psymb; s :] -> kont (f a e) s + | [: :] -> e ] + ; + + value sfold1sep f e entry symbl psymb psep = + let failed = + fun + [ [symb; sep] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" ] + in + let parse_top = + fun + [ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *) + | _ -> raise Stream.Failure ] + in + let rec kont accu = + parser + [ [: () = psep; + a = + parser + [ [: a = psymb :] -> a + | [: a = parse_top symbl :] -> Obj.magic a + | [: :] -> raise (Stream.Error (failed symbl)) ]; + s :] -> + kont (f a accu) s + | [: :] -> accu ] + in + parser [: a = psymb; s :] -> kont (f a e) s + ; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.mli new file mode 100644 index 0000000000..0b9b22b791 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Fold.mli @@ -0,0 +1,30 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) : sig + open Structure; + + value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; + (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Insert.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Insert.ml new file mode 100644 index 0000000000..a6cbf0eeed --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Insert.ml @@ -0,0 +1,327 @@ +(* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Parser = Parser.Make Structure; + open Structure; + open Format; + open Sig.Grammar; + + value is_before s1 s2 = + match (s1, s2) with + [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False + | (Skeyword _ | Stoken _, _) -> True + | _ -> False ] + ; + value rec derive_eps = + fun + [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True + | Stry s -> derive_eps s + | Stree t -> tree_derive_eps t + | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ -> + (* For sure we cannot derive epsilon from these *) + False + | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself -> + (* Approximation *) + False ] + and tree_derive_eps = + fun + [ LocAct _ _ -> True + | Node {node = s; brother = bro; son = son} -> + derive_eps s && tree_derive_eps son || tree_derive_eps bro + | DeadEnd -> False ] + ; + + value empty_lev lname assoc = + let assoc = + match assoc with + [ Some a -> a + | None -> LeftA ] + in + {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} + ; + value change_lev entry lev n lname assoc = + let a = + match assoc with + [ None -> lev.assoc + | Some a -> + do { + if a <> lev.assoc && entry.egram.warning_verbose.val then do { + eprintf "<W> Changing associativity of level \"%s\"\n" n; + flush Pervasives.stderr + } + else (); + a + } ] + in + do { + match lname with + [ Some n -> + if lname <> lev.lname && entry.egram.warning_verbose.val then do { + eprintf "<W> Level label \"%s\" ignored\n" n; flush Pervasives.stderr + } + else () + | None -> () ]; + {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; + lprefix = lev.lprefix} + } + ; + value change_to_self entry = + fun + [ Snterm e when e == entry -> Sself + | x -> x ] + ; + + + value get_level entry position levs = + match position with + [ Some First -> ([], empty_lev, levs) + | Some Last -> (levs, empty_lev, []) + | Some (Level n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | Some (Before n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs]) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | Some (After n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([lev], empty_lev, levs) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | None -> + match levs with + [ [lev :: levs] -> ([], change_lev entry lev "<top>", levs) + | [] -> ([], empty_lev, []) ] ] + ; + + value rec check_gram entry = + fun + [ Snterm e -> + if e.egram != entry.egram then do { + eprintf "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush Pervasives.stderr; + failwith "Grammar.extend error" + } + else () + | Snterml e _ -> + if e.egram != entry.egram then do { + eprintf "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush Pervasives.stderr; + failwith "Grammar.extend error" + } + else () + | Smeta _ sl _ -> List.iter (check_gram entry) sl + | Slist0sep s t -> do { check_gram entry t; check_gram entry s } + | Slist1sep s t -> do { check_gram entry t; check_gram entry s } + | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s + | Stree t -> tree_check_gram entry t + | Snext | Sself | Stoken _ | Skeyword _ -> () ] + and tree_check_gram entry = + fun + [ Node {node = n; brother = bro; son = son} -> + do { + check_gram entry n; + tree_check_gram entry bro; + tree_check_gram entry son + } + | LocAct _ _ | DeadEnd -> () ] + ; + value get_initial = + fun + [ [Sself :: symbols] -> (True, symbols) + | symbols -> (False, symbols) ] + ; + + + value insert_tokens gram symbols = + let rec insert = + fun + [ Smeta _ sl _ -> List.iter insert sl + | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s + | Slist0sep s t -> do { insert s; insert t } + | Slist1sep s t -> do { insert s; insert t } + | Stree t -> tinsert t + | Skeyword kwd -> using gram kwd + | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ] + and tinsert = + fun + [ Node {node = s; brother = bro; son = son} -> + do { insert s; tinsert bro; tinsert son } + | LocAct _ _ | DeadEnd -> () ] + in + List.iter insert symbols + ; + + value insert_tree entry gsymbols action tree = + let rec insert symbols tree = + match symbols with + [ [s :: sl] -> insert_in_tree s sl tree + | [] -> + match tree with + [ Node {node = s; son = son; brother = bro} -> + Node {node = s; son = son; brother = insert [] bro} + | LocAct old_action action_list -> + let () = + if entry.egram.warning_verbose.val then + eprintf "<W> Grammar extension: in [%s] some rule has been masked@." + entry.ename + else () + in LocAct action [old_action :: action_list] + | DeadEnd -> LocAct action [] ] ] + and insert_in_tree s sl tree = + match try_insert s sl tree with + [ Some t -> t + | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] + and try_insert s sl tree = + match tree with + [ Node {node = s1; son = son; brother = bro} -> + if Tools.eq_symbol s s1 then + let t = Node {node = s1; son = insert sl son; brother = bro} in + Some t + else if is_before s1 s || derive_eps s && not (derive_eps s1) then + let bro = + match try_insert s sl bro with + [ Some bro -> bro + | None -> + Node {node = s; son = insert sl DeadEnd; brother = bro} ] + in + let t = Node {node = s1; son = son; brother = bro} in + Some t + else + match try_insert s sl bro with + [ Some bro -> + let t = Node {node = s1; son = son; brother = bro} in + Some t + | None -> None ] + | LocAct _ _ | DeadEnd -> None ] + and insert_new = + fun + [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} + | [] -> LocAct action [] ] + in + insert gsymbols tree + ; + value insert_level entry e1 symbols action slev = + match e1 with + [ True -> + {assoc = slev.assoc; lname = slev.lname; + lsuffix = insert_tree entry symbols action slev.lsuffix; + lprefix = slev.lprefix} + | False -> + {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; + lprefix = insert_tree entry symbols action slev.lprefix} ] + ; + + value levels_of_rules entry position rules = + let elev = + match entry.edesc with + [ Dlevels elev -> elev + | Dparser _ -> + do { + eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } ] + in + if rules = [] then elev + else + let (levs1, make_lev, levs2) = get_level entry position elev in + let (levs, _) = + List.fold_left + (fun (levs, make_lev) (lname, assoc, level) -> + let lev = make_lev lname assoc in + let lev = + List.fold_left + (fun lev (symbols, action) -> + let symbols = List.map (change_to_self entry) symbols in + do { + List.iter (check_gram entry) symbols; + let (e1, symbols) = get_initial symbols; + insert_tokens entry.egram symbols; + insert_level entry e1 symbols action lev + }) + lev level + in + ([lev :: levs], empty_lev)) + ([], make_lev) rules + in + levs1 @ List.rev levs @ levs2 + ; + + value extend entry (position, rules) = + let elev = levels_of_rules entry position rules in + do { + entry.edesc := Dlevels elev; + entry.estart := + fun lev strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev strm }; + entry.econtinue := + fun lev bp a strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a strm } + }; + + end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.ml new file mode 100644 index 0000000000..89bbe884df --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -0,0 +1,425 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Failed = Failed.Make Structure; + module Print = Print.Make Structure; + open Structure; + open Sig.Grammar; + + module StreamOrig = Stream; + + value njunk strm n = + for i = 1 to n do Stream.junk strm done; + + value loc_bp = Tools.get_cur_loc; + value loc_ep = Tools.get_prev_loc; + value drop_prev_loc = Tools.drop_prev_loc; + + value add_loc bp parse_fun strm = + let x = parse_fun strm in + let ep = loc_ep strm in + let loc = Loc.merge bp ep in + (x, loc); + + value stream_peek_nth strm n = + let rec loop i = fun + [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs + | [] -> None ] + in + loop n (Stream.npeek n strm); + + (* We don't want Stream's functions to be used implictly. *) + module Stream = struct + type t 'a = StreamOrig.t 'a; + exception Failure = StreamOrig.Failure; + exception Error = StreamOrig.Error; + value peek = StreamOrig.peek; + value junk = StreamOrig.junk; + + value dup strm = + (* This version of peek_nth is off-by-one from Stream.peek_nth *) + let peek_nth n = + loop n (Stream.npeek (n + 1) strm) where rec loop n = + fun + [ [] -> None + | [x] -> if n = 0 then Some x else None + | [_ :: l] -> loop (n - 1) l ] + in + Stream.from peek_nth; + end; + + value try_parser ps strm = + let strm' = Stream.dup strm in + let r = + try ps strm' + with + [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) -> + raise Stream.Failure + | exc -> raise exc ] + in do { + njunk strm (StreamOrig.count strm'); + r; + }; + + value level_number entry lab = + let rec lookup levn = + fun + [ [] -> failwith ("unknown level " ^ lab) + | [lev :: levs] -> + if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ] + in + match entry.edesc with + [ Dlevels elev -> lookup 0 elev + | Dparser _ -> raise Not_found ] + ; + value strict_parsing = ref False; + value strict_parsing_warning = ref False; + + value rec top_symb entry = + fun + [ Sself | Snext -> Snterm entry + | Snterml e _ -> Snterm e + | Slist1sep s sep -> Slist1sep (top_symb entry s) sep + | _ -> raise Stream.Failure ] + ; + + value top_tree entry = + fun + [ Node {node = s; brother = bro; son = son} -> + Node {node = top_symb entry s; brother = bro; son = son} + | LocAct _ _ | DeadEnd -> raise Stream.Failure ] + ; + + value entry_of_symb entry = + fun + [ Sself | Snext -> entry + | Snterm e -> e + | Snterml e _ -> e + | _ -> raise Stream.Failure ] + ; + + value continue entry loc a s son p1 = + parser + [: a = (entry_of_symb entry s).econtinue 0 loc a; + act = p1 ?? Failed.tree_failed entry a s son :] -> + Action.mk (fun _ -> Action.getf act a) + ; + + (* PR#4603, PR#4330, PR#4551: + Here loc_bp replaced get_loc_ep to fix all these bugs. + If you do change it again look at these bugs. *) + value skip_if_empty bp strm = + if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure) + else + raise Stream.Failure + ; + + value do_recover parser_of_tree entry nlevn alevn loc a s son = + parser + [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a + | [: a = skip_if_empty loc :] -> a + | [: a = + continue entry loc a s son + (parser_of_tree entry nlevn alevn son) :] -> + a ] + ; + + + value recover parser_of_tree entry nlevn alevn loc a s son strm = + if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son)) + else + let _ = + if strict_parsing_warning.val then begin + let msg = Failed.tree_failed entry a s son; + Format.eprintf "Warning: trying to recover from syntax error"; + if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); + Format.eprintf "\n%s%a@." msg Loc.print loc; + end else () in + do_recover parser_of_tree entry nlevn alevn loc a s son strm + ; + + value rec parser_of_tree entry nlevn alevn = + fun + [ DeadEnd -> parser [] + | LocAct act _ -> parser [: :] -> act + | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> + parser [: a = entry.estart alevn :] -> Action.getf act a + | Node {node = Sself; son = LocAct act _; brother = bro} -> + let p2 = parser_of_tree entry nlevn alevn bro in + parser + [ [: a = entry.estart alevn :] -> Action.getf act a + | [: a = p2 :] -> a ] + | Node {node = s; son = son; brother = DeadEnd} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let ps = parser_of_symbol entry nlevn s in + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn s son in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | Some (tokl, last_tok, son) -> + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn last_tok son in + parser_of_token_list p1 tokl ] + | Node {node = s; son = son; brother = bro} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let ps = parser_of_symbol entry nlevn s in + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn s son in + let p2 = parser_of_tree entry nlevn alevn bro in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [ [: a = ps; act = p1 bp a :] -> Action.getf act a + | [: a = p2 :] -> a ] + | Some (tokl, last_tok, son) -> + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn last_tok son in + let p1 = parser_of_token_list p1 tokl in + let p2 = parser_of_tree entry nlevn alevn bro in + parser + [ [: a = p1 :] -> a + | [: a = p2 :] -> a ] ] ] + and parser_cont p1 entry nlevn alevn s son loc a = + parser + [ [: a = p1 :] -> a + | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a + | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ] + and parser_of_token_list p1 tokl = + loop 1 tokl where rec loop n = + fun + [ [Stoken (tematch, _) :: tokl] -> + match tokl with + [ [] -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok) + | _ -> raise Stream.Failure ] + in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | _ -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when tematch tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + parser [: tok = ps; s :] -> + let act = p1 s in Action.getf act tok ] + | [Skeyword kwd :: tokl] -> + match tokl with + [ [] -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when Token.match_keyword kwd tok -> + (njunk strm n; Action.mk tok) + | _ -> raise Stream.Failure ] + in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | _ -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when Token.match_keyword kwd tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + parser [: tok = ps; s :] -> + let act = p1 s in Action.getf act tok ] + | _ -> invalid_arg "parser_of_token_list" ] + and parser_of_symbol entry nlevn = + fun + [ Smeta _ symbl act -> + let act = Obj.magic act entry symbl in + let pl = List.map (parser_of_symbol entry nlevn) symbl in + Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) + | Slist0 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop al = + parser + [ [: a = ps; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = loop [] :] -> Action.mk (List.rev a) + | Slist0sep symb sep -> + let ps = parser_of_symbol entry nlevn symb in + let pt = parser_of_symbol entry nlevn sep in + let rec kont al = + parser + [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb; + s :] -> + kont [a :: al] s + | [: :] -> al ] + in + parser + [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) + | [: :] -> Action.mk [] ] + | Slist1 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop al = + parser + [ [: a = ps; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s)) + | Slist1sep symb sep -> + let ps = parser_of_symbol entry nlevn symb in + let pt = parser_of_symbol entry nlevn sep in + let rec kont al = + parser + [ [: v = pt; + a = + parser + [ [: a = ps :] -> a + | [: a = parse_top_symb entry symb :] -> a + | [: :] -> + raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; + s :] -> + kont [a :: al] s + | [: :] -> al ] + in + parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) + | Sopt s -> + let ps = parser_of_symbol entry nlevn s in + parser + [ [: a = ps :] -> Action.mk (Some a) + | [: :] -> Action.mk None ] + | Stry s -> + let ps = parser_of_symbol entry nlevn s in + try_parser ps + | Stree t -> + let pt = parser_of_tree entry 1 0 t in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: (act, loc) = add_loc bp pt :] -> + Action.getf act loc + | Snterm e -> parser [: a = e.estart 0 :] -> a + | Snterml e l -> + parser [: a = e.estart (level_number e l) :] -> a + | Sself -> parser [: a = entry.estart 0 :] -> a + | Snext -> parser [: a = entry.estart nlevn :] -> a + | Skeyword kwd -> + parser + [: `(tok, _) when Token.match_keyword kwd tok :] -> + Action.mk tok + | Stoken (f, _) -> + parser + [: `(tok,_) when f tok :] -> Action.mk tok ] + and parse_top_symb entry symb strm = + parser_of_symbol entry 0 (top_symb entry symb) strm; + + value rec start_parser_of_levels entry clevn = + fun + [ [] -> fun _ -> parser [] + | [lev :: levs] -> + let p1 = start_parser_of_levels entry (succ clevn) levs in + match lev.lprefix with + [ DeadEnd -> p1 + | tree -> + let alevn = + match lev.assoc with + [ LeftA | NonA -> succ clevn + | RightA -> clevn ] + in + let p2 = parser_of_tree entry (succ clevn) alevn tree in + match levs with + [ [] -> + fun levn strm -> + let bp = loc_bp strm in + match strm with parser + [: (act, loc) = add_loc bp p2; strm :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a strm + | _ -> + fun levn strm -> + if levn > clevn then p1 levn strm + else + let bp = loc_bp strm in + match strm with parser + [ [: (act, loc) = add_loc bp p2 :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a strm + | [: act = p1 levn :] -> act ] ] ] ] + ; + + value start_parser_of_entry entry = + debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in + match entry.edesc with + [ Dlevels [] -> Tools.empty_entry entry.ename + | Dlevels elev -> start_parser_of_levels entry 0 elev + | Dparser p -> fun _ -> p ] + ; + value rec continue_parser_of_levels entry clevn = + fun + [ [] -> fun _ _ _ -> parser [] + | [lev :: levs] -> + let p1 = continue_parser_of_levels entry (succ clevn) levs in + match lev.lsuffix with + [ DeadEnd -> p1 + | tree -> + let alevn = + match lev.assoc with + [ LeftA | NonA -> succ clevn + | RightA -> clevn ] + in + let p2 = parser_of_tree entry (succ clevn) alevn tree in + fun levn bp a strm -> + if levn > clevn then p1 levn bp a strm + else + match strm with parser + [ [: act = p1 levn bp a :] -> act + | [: (act, loc) = add_loc bp p2 :] -> + let a = Action.getf2 act a loc in + entry.econtinue levn loc a strm ] ] ] + ; + + value continue_parser_of_entry entry = + debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in + match entry.edesc with + [ Dlevels elev -> + let p = continue_parser_of_levels entry 0 elev in + fun levn bp a -> + parser + [ [: a = p levn bp a :] -> a + | [: :] -> a ] + | Dparser _ -> fun _ _ _ -> parser [] ] + ; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.mli new file mode 100644 index 0000000000..7b7cbe5a2b --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Parser.mli @@ -0,0 +1,62 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 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 (Structure : Structure.S) : sig + open Structure; + value add_loc : + Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t); + value level_number : internal_entry -> string -> int; + value strict_parsing : ref bool; + value strict_parsing_warning : ref bool; + value top_symb : + internal_entry -> symbol -> symbol; + value top_tree : + internal_entry -> tree -> tree; + value entry_of_symb : + internal_entry -> symbol -> internal_entry; + value continue : + internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun; + value do_recover : + (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> + 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; + value recover : + (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> + 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; + value parser_of_tree : + internal_entry -> int -> int -> tree -> efun; + value parser_cont : + efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun; + value parser_of_token_list : + (Loc.t -> Action.t -> efun) -> list symbol -> efun; + value parser_of_symbol : + internal_entry -> int -> symbol -> efun; + value parse_top_symb : + internal_entry -> symbol -> efun; + value start_parser_of_levels : + internal_entry -> int -> list level -> int -> efun; + value start_parser_of_entry : + internal_entry -> int -> efun; + value continue_parser_of_levels : + internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun; + value continue_parser_of_entry : + internal_entry -> int -> Loc.t -> Action.t -> efun; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.ml new file mode 100644 index 0000000000..77000c88aa --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.ml @@ -0,0 +1,270 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + open Structure; + open Format; + open Sig.Grammar; + + value rec flatten_tree = + fun + [ DeadEnd -> [] + | LocAct _ _ -> [[]] + | Node {node = n; brother = b; son = s} -> + [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ]; + + value rec print_symbol ppf = + fun + [ Smeta n sl _ -> print_meta ppf n sl + | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s + | Slist0sep s t -> + fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t + | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s + | Slist1sep s t -> + fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t + | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s + | Stry s -> fprintf ppf "TRY %a" print_symbol1 s + | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l + | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> + print_symbol1 ppf s ] + and print_meta ppf n sl = + loop 0 sl where rec loop i = + fun + [ [] -> () + | [s :: sl] -> + let j = + try String.index_from n i ' ' with [ Not_found -> String.length n ] + in + do { + fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; + if sl = [] then () + else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } + } ] + and print_symbol1 ppf = + fun + [ Snterm e -> pp_print_string ppf e.ename + | Sself -> pp_print_string ppf "SELF" + | Snext -> pp_print_string ppf "NEXT" + | Stoken (_, descr) -> pp_print_string ppf descr + | Skeyword s -> fprintf ppf "%S" s + | Stree t -> print_level ppf pp_print_space (flatten_tree t) + | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ as s -> + fprintf ppf "(%a)" print_symbol s ] + and print_rule ppf symbols = + do { + fprintf ppf "@[<hov 0>"; + let _ = + List.fold_left + (fun sep symbol -> + do { + fprintf ppf "%t%a" sep print_symbol symbol; + fun ppf -> fprintf ppf ";@ " + }) + (fun _ -> ()) symbols + in + fprintf ppf "@]" + } + and print_level ppf pp_print_space rules = + do { + fprintf ppf "@[<hov 0>[ "; + let _ = + List.fold_left + (fun sep rule -> + do { + fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space () + }) + (fun _ -> ()) rules + in + fprintf ppf " ]@]" + } + ; + + value levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + let rules = + [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @ + flatten_tree lev.lprefix + in + do { + fprintf ppf "%t@[<hov 2>" sep; + match lev.lname with + [ Some n -> fprintf ppf "%S@;<1 2>" n + | None -> () ]; + match lev.assoc with + [ LeftA -> fprintf ppf "LEFTA" + | RightA -> fprintf ppf "RIGHTA" + | NonA -> fprintf ppf "NONA" ]; + fprintf ppf "@]@;<1 2>"; + print_level ppf pp_force_newline rules; + fun ppf -> fprintf ppf "@,| " + }) + (fun _ -> ()) elev + in + (); + + value entry ppf e = + do { + fprintf ppf "@[<v 0>%s: [ " e.ename; + match e.edesc with + [ Dlevels elev -> levels ppf elev + | Dparser _ -> fprintf ppf "<parser>" ]; + fprintf ppf " ]@]" + }; + +end; + +module MakeDump (Structure : Structure.S) = struct + open Structure; + open Format; + open Sig.Grammar; + + type brothers = [ Bro of symbol and list brothers ]; + + value rec print_tree ppf tree = + let rec get_brothers acc = + fun + [ DeadEnd -> List.rev acc + | LocAct _ _ -> List.rev acc + | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ] + and print_brothers ppf brothers = + if brothers = [] then fprintf ppf "@ []" + else + List.iter (fun [ Bro n xs -> do { + fprintf ppf "@ @[<hv2>- %a" print_symbol n; + match xs with + [ [] -> () + | [_] -> try print_children ppf (get_children [] xs) + with [ Exit -> fprintf ppf ":%a" print_brothers xs ] + | _ -> fprintf ppf ":%a" print_brothers xs ]; + fprintf ppf "@]"; + }]) brothers + and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) + and get_children acc = + fun + [ [] -> List.rev acc + | [Bro n x] -> get_children [n::acc] x + | _ -> raise Exit ] + in print_brothers ppf (get_brothers [] tree) + and print_symbol ppf = + fun + [ Smeta n sl _ -> print_meta ppf n sl + | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s + | Slist0sep s t -> + fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t + | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s + | Slist1sep s t -> + fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t + | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s + | Stry s -> fprintf ppf "TRY %a" print_symbol1 s + | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l + | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> + print_symbol1 ppf s ] + and print_meta ppf n sl = + loop 0 sl where rec loop i = + fun + [ [] -> () + | [s :: sl] -> + let j = + try String.index_from n i ' ' with [ Not_found -> String.length n ] + in + do { + fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; + if sl = [] then () + else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } + } ] + and print_symbol1 ppf = + fun + [ Snterm e -> pp_print_string ppf e.ename + | Sself -> pp_print_string ppf "SELF" + | Snext -> pp_print_string ppf "NEXT" + | Stoken (_, descr) -> pp_print_string ppf descr + | Skeyword s -> fprintf ppf "%S" s + | Stree t -> print_tree ppf t + | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ as s -> + fprintf ppf "(%a)" print_symbol s ] + and print_rule ppf symbols = + do { + fprintf ppf "@[<hov 0>"; + let _ = + List.fold_left + (fun sep symbol -> + do { + fprintf ppf "%t%a" sep print_symbol symbol; + fun ppf -> fprintf ppf ";@ " + }) + (fun _ -> ()) symbols + in + fprintf ppf "@]" + } + and print_level ppf pp_print_space rules = + do { + fprintf ppf "@[<hov 0>[ "; + let _ = + List.fold_left + (fun sep rule -> + do { + fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space () + }) + (fun _ -> ()) rules + in + fprintf ppf " ]@]" + } + ; + + value levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + do { + fprintf ppf "%t@[<v2>" sep; + match lev.lname with + [ Some n -> fprintf ppf "%S@;<1 2>" n + | None -> () ]; + match lev.assoc with + [ LeftA -> fprintf ppf "LEFTA" + | RightA -> fprintf ppf "RIGHTA" + | NonA -> fprintf ppf "NONA" ]; + fprintf ppf "@]@;<1 2>"; + fprintf ppf "@[<v2>suffix:@ "; + print_tree ppf lev.lsuffix; + fprintf ppf "@]@ @[<v2>prefix:@ "; + print_tree ppf lev.lprefix; + fprintf ppf "@]"; + fun ppf -> fprintf ppf "@,| " + }) + (fun _ -> ()) elev + in + (); + + value entry ppf e = + do { + fprintf ppf "@[<v 0>%s: [ " e.ename; + match e.edesc with + [ Dlevels elev -> levels ppf elev + | Dparser _ -> fprintf ppf "<parser>" ]; + fprintf ppf " ]@]" + }; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.mli new file mode 100644 index 0000000000..9acc836de2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Print.mli @@ -0,0 +1,47 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) : sig + value flatten_tree : Structure.tree -> list (list Structure.symbol); + value print_symbol : Format.formatter -> Structure.symbol -> unit; + value print_meta : + Format.formatter -> string -> list Structure.symbol -> unit; + value print_symbol1 : Format.formatter -> Structure.symbol -> unit; + value print_rule : Format.formatter -> list Structure.symbol -> unit; + value print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + list (list Structure.symbol) -> unit; + value levels : Format.formatter -> list Structure.level -> unit; + value entry : Format.formatter -> Structure.internal_entry -> unit; +end; + +module MakeDump (Structure : Structure.S) : sig + value print_symbol : Format.formatter -> Structure.symbol -> unit; + value print_meta : + Format.formatter -> string -> list Structure.symbol -> unit; + value print_symbol1 : Format.formatter -> Structure.symbol -> unit; + value print_rule : Format.formatter -> list Structure.symbol -> unit; + value print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + list (list Structure.symbol) -> unit; + value levels : Format.formatter -> list Structure.level -> unit; + value entry : Format.formatter -> Structure.internal_entry -> unit; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Search.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Search.ml new file mode 100644 index 0000000000..bc4ed301ad --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Search.ml @@ -0,0 +1,95 @@ +(****************************************************************************) +(* *) +(* 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 (Structure : Structure.S) = struct + open Structure; +value tree_in_entry prev_symb tree = + fun + [ Dlevels levels -> + let rec search_levels = + fun + [ [] -> tree + | [level :: levels] -> + match search_level level with + [ Some tree -> tree + | None -> search_levels levels ] ] + and search_level level = + match search_tree level.lsuffix with + [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) + | None -> search_tree level.lprefix ] + and search_tree t = + if tree <> DeadEnd && t == tree then Some t + else + match t with + [ Node n -> + match search_symbol n.node with + [ Some symb -> + Some (Node {node = symb; son = n.son; brother = DeadEnd}) + | None -> + match search_tree n.son with + [ Some t -> + Some (Node {node = n.node; son = t; brother = DeadEnd}) + | None -> search_tree n.brother ] ] + | LocAct _ _ | DeadEnd -> None ] + and search_symbol symb = + match symb with + [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ + when symb == prev_symb -> + Some symb + | Slist0 symb -> + match search_symbol symb with + [ Some symb -> Some (Slist0 symb) + | None -> None ] + | Slist0sep symb sep -> + match search_symbol symb with + [ Some symb -> Some (Slist0sep symb sep) + | None -> + match search_symbol sep with + [ Some sep -> Some (Slist0sep symb sep) + | None -> None ] ] + | Slist1 symb -> + match search_symbol symb with + [ Some symb -> Some (Slist1 symb) + | None -> None ] + | Slist1sep symb sep -> + match search_symbol symb with + [ Some symb -> Some (Slist1sep symb sep) + | None -> + match search_symbol sep with + [ Some sep -> Some (Slist1sep symb sep) + | None -> None ] ] + | Sopt symb -> + match search_symbol symb with + [ Some symb -> Some (Sopt symb) + | None -> None ] + | Stry symb -> + match search_symbol symb with + [ Some symb -> Some (Stry symb) + | None -> None ] + | Stree t -> + match search_tree t with + [ Some t -> Some (Stree t) + | None -> None ] + | _ -> None ] + in + search_levels levels + | Dparser _ -> tree ] +; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Static.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Static.ml new file mode 100644 index 0000000000..a94c9fa1c5 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Static.ml @@ -0,0 +1,84 @@ +(****************************************************************************) +(* *) +(* 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 +*) + +value uncurry f (x,y) = f x y; +value flip f x y = f y x; + +module Make (Lexer : Sig.Lexer) +: Sig.Grammar.Static with module Loc = Lexer.Loc + and module Token = Lexer.Token += struct + module Structure = Structure.Make Lexer; + module Delete = Delete.Make Structure; + module Insert = Insert.Make Structure; + module Fold = Fold.Make Structure; + module Tools = Tools.Make Structure; + include Structure; + + value gram = + let gkeywords = Hashtbl.create 301 in + { + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref True; (* FIXME *) + error_verbose = Camlp4_config.verbose + }; + + module Entry = struct + module E = Entry.Make Structure; + type t 'a = E.t 'a; + value mk = E.mk gram; + value of_parser name strm = E.of_parser gram name strm; + value setup_parser = E.setup_parser; + value name = E.name; + value print = E.print; + value clear = E.clear; + value dump = E.dump; + value obj x = x; + end; + + value get_filter () = gram.gfilter; + + value lex loc cs = gram.glexer loc cs; + + value lex_string loc str = lex loc (Stream.of_string str); + + value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts); + + value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts; + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs); + + value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str); + + value delete_rule = Delete.delete_rule; + + value srules e rl = + Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); + value sfold0 = Fold.sfold0; + value sfold1 = Fold.sfold1; + value sfold0sep = Fold.sfold0sep; + (* value sfold1sep = Fold.sfold1sep; *) + + value extend = Insert.extend; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Structure.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Structure.ml new file mode 100644 index 0000000000..c2afdd6395 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Structure.ml @@ -0,0 +1,292 @@ +(****************************************************************************) +(* *) +(* 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 + *) + +open Sig.Grammar; + +module type S = sig + module Loc : Sig.Loc; + module Token : Sig.Token with module Loc = Loc; + module Lexer : Sig.Lexer + with module Loc = Loc + and module Token = Token; + module Action : Sig.Grammar.Action; + + type gram = + { gfilter : Token.Filter.t; + gkeywords : Hashtbl.t string (ref int); + glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + warning_verbose : ref bool; + error_verbose : ref bool }; + + type token_info = { prev_loc : Loc.t + ; cur_loc : Loc.t + }; + + type token_stream = Stream.t (Token.t * token_info); + + type efun = token_stream -> Action.t; + + type token_pattern = ((Token.t -> bool) * string); + + type internal_entry = + { egram : gram; + ename : string; + estart : mutable int -> efun; + econtinue : mutable int -> Loc.t -> Action.t -> efun; + edesc : mutable desc } + and desc = + [ Dlevels of list level + | Dparser of token_stream -> Action.t ] + and level = + { assoc : assoc ; + lname : option string ; + lsuffix : tree ; + lprefix : tree } + and symbol = + [ Smeta of string and list symbol and Action.t + | Snterm of internal_entry + | Snterml of internal_entry and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Stry of symbol + | Sself + | Snext + | Stoken of token_pattern + | Skeyword of string + | Stree of tree ] + and tree = + [ Node of node + | LocAct of Action.t and list Action.t + | DeadEnd ] + and node = + { node : symbol ; + son : tree ; + brother : tree }; + + type production_rule = (list symbol * Action.t); + type single_extend_statment = + (option string * option assoc * list production_rule); + type extend_statment = + (option position * list single_extend_statment); + type delete_statment = list symbol; + + type fold 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; + + type foldsep 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; + + (* Accessors *) + value get_filter : gram -> Token.Filter.t; + + (* Useful functions *) + value using : gram -> string -> unit; + value removing : gram -> string -> unit; +end; + +module Make (Lexer : Sig.Lexer) = struct + module Loc = Lexer.Loc; + module Token = Lexer.Token; + module Action : Sig.Grammar.Action = struct + type t = Obj.t ; + value mk = Obj.repr; + value get = Obj.obj ; + value getf = Obj.obj ; + value getf2 = Obj.obj ; + end; + module Lexer = Lexer; + + type gram = + { gfilter : Token.Filter.t; + gkeywords : Hashtbl.t string (ref int); + glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + warning_verbose : ref bool; + error_verbose : ref bool }; + + type token_info = { prev_loc : Loc.t + ; cur_loc : Loc.t + }; + + type token_stream = Stream.t (Token.t * token_info); + + type efun = token_stream -> Action.t; + + type token_pattern = ((Token.t -> bool) * string); + + type internal_entry = + { egram : gram; + ename : string; + estart : mutable int -> efun; + econtinue : mutable int -> Loc.t -> Action.t -> efun; + edesc : mutable desc } + and desc = + [ Dlevels of list level + | Dparser of token_stream -> Action.t ] + and level = + { assoc : assoc ; + lname : option string ; + lsuffix : tree ; + lprefix : tree } + and symbol = + [ Smeta of string and list symbol and Action.t + | Snterm of internal_entry + | Snterml of internal_entry and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Stry of symbol + | Sself + | Snext + | Stoken of token_pattern + | Skeyword of string + | Stree of tree ] + and tree = + [ Node of node + | LocAct of Action.t and list Action.t + | DeadEnd ] + and node = + { node : symbol ; + son : tree ; + brother : tree }; + + type production_rule = (list symbol * Action.t); + type single_extend_statment = + (option string * option assoc * list production_rule); + type extend_statment = + (option position * list single_extend_statment); + type delete_statment = list symbol; + + type fold 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; + + type foldsep 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; + + value get_filter g = g.gfilter; + value token_location r = r.cur_loc; + + type not_filtered 'a = 'a; + value using { gkeywords = table; gfilter = filter } kwd = + let r = try Hashtbl.find table kwd with + [ Not_found -> + let r = ref 0 in do { Hashtbl.add table kwd r; r } ] + in do { Token.Filter.keyword_added filter kwd (r.val = 0); + incr r }; + + value removing { gkeywords = table; gfilter = filter } kwd = + let r = Hashtbl.find table kwd in + let () = decr r in + if r.val = 0 then do { + Token.Filter.keyword_removed filter kwd; + Hashtbl.remove table kwd + } else (); +end; + +(* +value iter_entry f e = + let treated = ref [] in + let rec do_entry e = + if List.memq e treated.val then () + else do { + treated.val := [e :: treated.val]; + f e; + match e.edesc with + [ Dlevels ll -> List.iter do_level ll + | Dparser _ -> () ] + } + and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } + and do_tree = + fun + [ Node n -> do_node n + | LocAct _ _ | DeadEnd -> () ] + and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } + and do_symbol = + fun + [ Smeta _ sl _ -> List.iter do_symbol sl + | Snterm e | Snterml e _ -> do_entry e + | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } + | Stree t -> do_tree t + | Sself | Snext | Stoken _ | Stoken_fun _ -> () ] + in + do_entry e +; + +value fold_entry f e init = + let treated = ref [] in + let rec do_entry accu e = + if List.memq e treated.val then accu + else do { + treated.val := [e :: treated.val]; + let accu = f e accu in + match e.edesc with + [ Dlevels ll -> List.fold_left do_level accu ll + | Dparser _ -> accu ] + } + and do_level accu lev = + let accu = do_tree accu lev.lsuffix in + do_tree accu lev.lprefix + and do_tree accu = + fun + [ Node n -> do_node accu n + | LocAct _ _ | DeadEnd -> accu ] + and do_node accu n = + let accu = do_symbol accu n.node in + let accu = do_tree accu n.son in + do_tree accu n.brother + and do_symbol accu = + fun + [ Smeta _ sl _ -> List.fold_left do_symbol accu sl + | Snterm e | Snterml e _ -> do_entry accu e + | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> + let accu = do_symbol accu s1 in + do_symbol accu s2 + | Stree t -> do_tree accu t + | Sself | Snext | Stoken _ | Stoken_fun _ -> accu ] + in + do_entry init e +; + +value is_level_labelled n lev = + match lev.lname with + [ Some n1 -> n = n1 + | None -> False ] +; + +value tokens g con = + let list = ref [] in + do { + Hashtbl.iter + (fun (p_con, p_prm) c -> + if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) + g.gtokens; + list.val + } +; +*) diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Tools.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Tools.ml new file mode 100644 index 0000000000..4dae7e713f --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Grammar/Tools.ml @@ -0,0 +1,186 @@ +(****************************************************************************) +(* *) +(* 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 + *) + +(* BEGIN ugly hack. See 15 lines down. FIXME *) + +type prev_locs = { + pl_strm : mutable Obj.t; + pl_locs : mutable list (int * Obj.t) +}; + +value prev_locs = ref ([] : list prev_locs); + +(* END ugly hack FIXME *) + +module Make (Structure : Structure.S) = struct + open Structure; + + value empty_entry ename _ = + raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); + + value rec stream_map f = parser + [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] + | [: :] -> [: :] ]; + +(* ******************************************************************* *) +(* Ugly hack to prevent PR#5090. See how to do this properly after + the 3.12.0 release. FIXME. +*) + +value keep_prev_loc strm = + match Stream.peek strm with + [ None -> [: :] + | Some (_, init_loc) -> + let myrecord = { pl_strm = Obj.repr [: :]; + pl_locs = [(0, Obj.repr init_loc)] } + in + let rec go prev_loc = parser + [ [: `(tok, cur_loc); strm :] -> do { + myrecord.pl_locs := myrecord.pl_locs + @ [ (Stream.count strm, Obj.repr cur_loc) ]; + [: `(tok, {prev_loc; cur_loc}); go cur_loc strm :] } + | [: :] -> do { + prev_locs.val := List.filter ((!=) myrecord) prev_locs.val; + [: :] } ] + in + let result = go init_loc strm in + do { + prev_locs.val := [myrecord :: prev_locs.val]; + myrecord.pl_strm := Obj.repr result; + result } ]; + +value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r)) strm; + +value get_cur_loc strm = + match Stream.peek strm with + [ Some (_,r) -> r.cur_loc + | None -> Loc.ghost ]; + +value get_prev_loc strm = + let c = Stream.count strm in + let rec drop l = + match l with + [ [] -> [] + | [(i, _) :: ll] -> if i < c then drop ll else l ] + in + let rec find l = + match l with + [ [] -> None + | [h::t] -> if h.pl_strm == Obj.repr strm then Some h else find t ] + in + match find prev_locs.val with + [ None -> Loc.ghost + | Some r -> do { + r.pl_locs := drop r.pl_locs; + match r.pl_locs with + [ [] -> Loc.ghost + | [(i, loc) :: _] -> + if i = c then (Obj.obj loc : Loc.t) else Loc.ghost ] } ]; + +(* ******************************************************************* *) +(* END of ugly hack. This is the previous code. + + value keep_prev_loc strm = + match Stream.peek strm with + [ None -> [: :] + | Some (_,init_loc) -> + let rec go prev_loc = parser + [ [: `(tok,cur_loc); strm :] -> [: `(tok,{prev_loc;cur_loc}); go cur_loc strm :] + | [: :] -> [: :] ] + in go init_loc strm ]; + + value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; + + value get_cur_loc strm = + match Stream.peek strm with + [ Some (_,r) -> r.cur_loc + | None -> Loc.ghost ]; + + value get_prev_loc strm = + match Stream.peek strm with + [ Some (_,r) -> r.prev_loc + | None -> Loc.ghost ]; +*) + + + value is_level_labelled n lev = + match lev.lname with + [ Some n1 -> n = n1 + | None -> False ]; + + value warning_verbose = ref True; + + value rec get_token_list entry tokl last_tok tree = + match tree with + [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} -> + get_token_list entry [last_tok :: tokl] tok son + | _ -> + if tokl = [] then None + else Some (List.rev [last_tok :: tokl], last_tok, tree) ]; + + value is_antiquot s = + let len = String.length s in + len > 1 && s.[0] = '$'; + + value eq_Stoken_ids s1 s2 = + not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2; + + value logically_eq_symbols entry = + let rec eq_symbols s1 s2 = + match (s1, s2) with + [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename + | (Snterm e1, Sself) -> e1.ename = entry.ename + | (Sself, Snterm e2) -> entry.ename = e2.ename + | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 + | (Slist0 s1, Slist0 s2) | + (Slist1 s1, Slist1 s2) | + (Sopt s1, Sopt s2) | + (Stry s1, Stry s2) -> eq_symbols s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) | + (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 + | (Stree t1, Stree t2) -> eq_trees t1 t2 + | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 + | _ -> s1 = s2 ] + and eq_trees t1 t2 = + match (t1, t2) with + [ (Node n1, Node n2) -> + eq_symbols n1.node n2.node && eq_trees n1.son n2.son && + eq_trees n1.brother n2.brother + | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True + | _ -> False ] + in + eq_symbols; + + value rec eq_symbol s1 s2 = + match (s1, s2) with + [ (Snterm e1, Snterm e2) -> e1 == e2 + | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 + | (Slist0 s1, Slist0 s2) | + (Slist1 s1, Slist1 s2) | + (Sopt s1, Sopt s2) | + (Stry s1, Stry s2) -> eq_symbol s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) | + (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbol s1 s2 && eq_symbol sep1 sep2 + | (Stree _, Stree _) -> False + | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 + | _ -> s1 = s2 ] + ; +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll b/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll new file mode 100644 index 0000000000..b8e97efefb --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll @@ -0,0 +1,483 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-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 + *) + + + +(* The lexer definition *) + + +{ + +(** A lexical analyzer. *) + +(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) +(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) + +(* type context = +{ loc : Loc.t ; + in_comment : bool ; + |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the + quotation syntax any more. Default is False (quotations are + lexed). +| + quotations : bool }; + +value default_context : context; + +value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + +value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) +(* FIXME Beware the context argument must be given like that: + * mk' { (default_context) with ... = ... } strm + *) + +module TokenEval = Token.Eval +module Make (Token : Sig.Camlp4Token) += struct + module Loc = Token.Loc + module Token = Token + + open Lexing + open Sig + + (* Error report *) + module Error = struct + + type t = + | Illegal_character of char + | Illegal_escape of string + | Unterminated_comment + | Unterminated_string + | Unterminated_quotation + | Unterminated_antiquot + | Unterminated_string_in_comment + | Comment_start + | Comment_not_end + | Literal_overflow of string + + exception E of t + + open Format + + let print ppf = + function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Illegal_escape s -> + fprintf ppf "Illegal backslash escape in string or character (%s)" s + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Unterminated_quotation -> + fprintf ppf "Quotation not terminated" + | Unterminated_antiquot -> + fprintf ppf "Antiquotation not terminated" + | Literal_overflow ty -> + fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty + | Comment_start -> + fprintf ppf "this is the start of a comment" + | Comment_not_end -> + fprintf ppf "this is not the end of a comment" + + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end;; + + let module M = ErrorHandler.Register(Error) in () + + open Error + + (* To store some context information: + * loc : position of the beginning of a string, quotation and comment + * in_comment: are we in a comment? + * quotations: shall we lex quotation? + * If quotations is false it's a SYMBOL token. + * antiquots : shall we lex antiquotations. + *) + + type context = + { loc : Loc.t ; + in_comment : bool ; + quotations : bool ; + antiquots : bool ; + lexbuf : lexbuf ; + buffer : Buffer.t } + + let default_context lb = + { loc = Loc.ghost ; + in_comment = false ; + quotations = true ; + antiquots = false ; + lexbuf = lb ; + buffer = Buffer.create 256 } + + (* To buffer string literals, quotations and antiquotations *) + + let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) + let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) + let buff_contents c = + let contents = Buffer.contents c.buffer in + Buffer.reset c.buffer; contents + + let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) + let quotations c = c.quotations + let antiquots c = c.antiquots + let is_in_comment c = c.in_comment + let in_comment c = { (c) with in_comment = true } + let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc + let move_start_p shift c = + let p = c.lexbuf.lex_start_p in + c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } + + let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } + let with_curr_loc f c = f (update_loc c) c.lexbuf + let parse_nested f c = + with_curr_loc f c; + set_start_p c; + buff_contents c + let shift n c = { (c) with loc = Loc.move `both n c.loc } + let store_parse f c = store c ; f c c.lexbuf + let parse f c = f c c.lexbuf + let mk_quotation quotation c name loc shift = + let s = parse_nested quotation (update_loc c) in + let contents = String.sub s 0 (String.length s - 2) in + QUOTATION { q_name = name ; + q_loc = loc ; + q_shift = shift ; + q_contents = contents } + + + (* Update the current location with file name and line number. *) + + let update_loc c file line absolute chars = + let lexbuf = c.lexbuf in + let pos = lexbuf.lex_curr_p in + let new_file = match file with + | None -> pos.pos_fname + | Some s -> s + in + lexbuf.lex_curr_p <- { pos with + pos_fname = new_file; + pos_lnum = if absolute then line else pos.pos_lnum + line; + pos_bol = pos.pos_cnum - chars; + } + + let err error loc = + raise(Loc.Exc_located(loc, Error.E error)) + + let warn error loc = + Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error + + } + + let newline = ('\010' | '\013' | "\013\010") + let blank = [' ' '\009' '\012'] + let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] + let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] + let ident = (lowercase|uppercase) identchar* + let locname = ident + let not_star_symbolchar = + ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] + let symbolchar = '*' | not_star_symbolchar + let quotchar = + ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] + let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] + let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* + let hex_literal = + '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* + let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* + let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* + let int_literal = + decimal_literal | hex_literal | oct_literal | bin_literal + let float_literal = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? + + (* Delimitors are extended (from 3.09) in a conservative way *) + + (* These chars that can't start an expression or a pattern: *) + let safe_delimchars = ['%' '&' '/' '@' '^'] + + (* These symbols are unsafe since "[<", "[|", etc. exsist. *) + let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] + + let left_delims = ['(' '[' '{'] + let right_delims = [')' ']' '}'] + + let left_delimitor = + (* At least a safe_delimchars *) + left_delims delimchars* safe_delimchars (delimchars|left_delims)* + + (* A '(' or a new super '(' without "(<" *) + | '(' (['|' ':'] delimchars*)? + (* Old brackets, no new brackets starting with "[|" or "[:" *) + | '[' ['|' ':']? + (* Old "[<","{<" and new ones *) + | ['[' '{'] delimchars* '<' + (* Old brace and new ones *) + | '{' (['|' ':'] delimchars*)? + + let right_delimitor = + (* At least a safe_delimchars *) + (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims + (* A ')' or a new super ')' without ">)" *) + | (delimchars* ['|' ':'])? ')' + (* Old brackets, no new brackets ending with "|]" or ":]" *) + | ['|' ':']? ']' + (* Old ">]",">}" and new ones *) + | '>' delimchars* [']' '}'] + (* Old brace and new ones *) + | (delimchars* ['|' ':'])? '}' + + + rule token c = parse + | newline { update_loc c None 1 false 0; NEWLINE } + | blank + as x { BLANKS x } + | "~" (lowercase identchar * as x) ':' { LABEL x } + | "?" (lowercase identchar * as x) ':' { OPTLABEL x } + | lowercase identchar * as x { LIDENT x } + | uppercase identchar * as x { UIDENT x } + | int_literal as i + { try INT(int_of_string i, i) + with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } + | float_literal as f + { try FLOAT(float_of_string f, f) + with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "l" + { try INT32(Int32.of_string i, i) + with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "L" + { try INT64(Int64.of_string i, i) + with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "n" + { try NATIVEINT(Nativeint.of_string i, i) + with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } + | '"' + { with_curr_loc string c; + let s = buff_contents c in STRING (TokenEval.string s, s) } + | "'" (newline as x) "'" + { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } + | "'" ( [^ '\\' '\010' '\013'] + | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] + |['0'-'9'] ['0'-'9'] ['0'-'9'] + |'x' hexa_char hexa_char) + as x) "'" { CHAR (TokenEval.char x, x) } + | "'\\" (_ as c) + { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } + | "(*" + { store c; COMMENT(parse_nested comment (in_comment c)) } + | "(*)" + { warn Comment_start (Loc.of_lexbuf lexbuf) ; + parse comment (in_comment c); COMMENT (buff_contents c) } + | "*)" + { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; + move_start_p (-1) c; SYMBOL "*" } + | "<<" (quotchar* as beginning) + { if quotations c + then (move_start_p (-String.length beginning); + mk_quotation quotation c "" "" 2) + else parse (symbolchar_star ("<<" ^ beginning)) c } + | "<<>>" + { if quotations c + then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } + else parse (symbolchar_star "<<>>") c } + | "<@" + { if quotations c then with_curr_loc maybe_quotation_at c + else parse (symbolchar_star "<@") c } + | "<:" + { if quotations c then with_curr_loc maybe_quotation_colon c + else parse (symbolchar_star "<:") c } + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { let inum = int_of_string num + in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } + | '(' (not_star_symbolchar as op) ')' + { ESCAPED_IDENT (String.make 1 op) } + | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar+ as op) blank+ ')' + { ESCAPED_IDENT op } + | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" + | ":=" | ":>" | ";" | ";;" | "_" + | left_delimitor | right_delimitor ) as x { SYMBOL x } + | '$' { if antiquots c + then with_curr_loc dollar (shift 1 c) + else parse (symbolchar_star "$") c } + | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * + as x { SYMBOL x } + | eof + { let pos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; + pos_cnum = pos.pos_cnum + 1 }; EOI } + | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } + + and comment c = parse + "(*" + { store c; with_curr_loc comment c; parse comment c } + | "*)" { store c } + | '<' (':' ident)? ('@' locname)? '<' + { store c; + if quotations c then with_curr_loc quotation c; parse comment c } + | ident { store_parse comment c } + | "\"" + { store c; + begin try with_curr_loc string c + with Loc.Exc_located(_, Error.E Unterminated_string) -> + err Unterminated_string_in_comment (loc c) + end; + Buffer.add_char c.buffer '"'; + parse comment c } + | "''" { store_parse comment c } + | "'''" { store_parse comment c } + | "'" newline "'" + { update_loc c None 1 false 1; store_parse comment c } + | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } + | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } + | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } + | eof + { err Unterminated_comment (loc c) } + | newline + { update_loc c None 1 false 0; store_parse comment c } + | _ { store_parse comment c } + + and string c = parse + '"' { set_start_p c } + | '\\' newline ([' ' '\t'] * as space) + { update_loc c None 1 false (String.length space); + store_parse string c } + | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } + | '\\' 'x' hexa_char hexa_char { store_parse string c } + | '\\' (_ as x) + { if is_in_comment c + then store_parse string c + else begin + warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); + store_parse string c + end } + | newline + { update_loc c None 1 false 0; store_parse string c } + | eof { err Unterminated_string (loc c) } + | _ { store_parse string c } + + and symbolchar_star beginning c = parse + | symbolchar* as tok { move_start_p (-String.length beginning) c ; + SYMBOL(beginning ^ tok) } + + and maybe_quotation_at c = parse + | (ident as loc) '<' + { mk_quotation quotation c "" loc (1 + String.length loc) } + | symbolchar* as tok { SYMBOL("<@" ^ tok) } + + and maybe_quotation_colon c = parse + | (ident as name) '<' + { mk_quotation quotation c name "" (1 + String.length name) } + | (ident as name) '@' (locname as loc) '<' + { mk_quotation quotation c name loc + (2 + String.length loc + String.length name) } + | symbolchar* as tok { SYMBOL("<:" ^ tok) } + + and quotation c = parse + | '<' (':' ident)? ('@' locname)? '<' { store c ; + with_curr_loc quotation c ; + parse quotation c } + | ">>" { store c } + | eof { err Unterminated_quotation (loc c) } + | newline { update_loc c None 1 false 0 ; + store_parse quotation c } + | _ { store_parse quotation c } + + and dollar c = parse + | '$' { set_start_p c; ANTIQUOT("", "") } + | ('`'? (identchar*|['.' '!']+) as name) ':' + { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } + | _ { store_parse (antiquot "") c } + + and antiquot name c = parse + | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } + | eof { err Unterminated_antiquot (loc c) } + | newline + { update_loc c None 1 false 0; store_parse (antiquot name) c } + | '<' (':' ident)? ('@' locname)? '<' + { store c; with_curr_loc quotation c; parse (antiquot name) c } + | _ { store_parse (antiquot name) c } + + { + + let lexing_store s buff max = + let rec self n s = + if n >= max then n + else + match Stream.peek s with + | Some x -> + Stream.junk s; + buff.[n] <- x; + succ n + | _ -> n + in + self 0 s + + let from_context c = + let next _ = + let tok = with_curr_loc token c in + let loc = Loc.of_lexbuf c.lexbuf in + Some ((tok, loc)) + in Stream.from next + + let from_lexbuf ?(quotations = true) lb = + let c = { (default_context lb) with + loc = Loc.of_lexbuf lb; + antiquots = !Camlp4_config.antiquotations; + quotations = quotations } + in from_context c + + let setup_loc lb loc = + let start_pos = Loc.start_pos loc in + lb.lex_abs_pos <- start_pos.pos_cnum; + lb.lex_curr_p <- start_pos + + let from_string ?quotations loc str = + let lb = Lexing.from_string str in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let from_stream ?quotations loc strm = + let lb = Lexing.from_function (lexing_store strm) in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let mk () loc strm = + from_stream ~quotations:!Camlp4_config.quotations loc strm +end +} diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml new file mode 100644 index 0000000000..ac42d4b1c4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.ml @@ -0,0 +1,307 @@ +(****************************************************************************) +(* *) +(* 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 + *) +(* camlp4r *) + +open Format; + +(* FIXME + Study these 2 others implementations which change the ghost + handling: + + type pos = ... the same ... + + 1/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = + [ Nowhere + | Ghost of loc (* the closest non ghost loc *) + | Concrete of loc ]; + + 2/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = option loc; + + 3/ + + type t = { + file_name : option string; + start : pos; + stop : pos + }; + +*) + +type pos = { + line : int; + bol : int; + off : int +}; + +type t = { + file_name : string; + start : pos; + stop : pos; + ghost : bool +}; + +(* Debug section *) +value dump_sel f x = + let s = + match x with + [ `start -> "`start" + | `stop -> "`stop" + | `both -> "`both" + | _ -> "<not-printable>" ] + in pp_print_string f s; +value dump_pos f x = + fprintf f "@[<hov 2>{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" + x.line x.bol x.off; +value dump_long f x = + fprintf f + "@[<hov 2>{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" + x.file_name dump_pos x.start (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) dump_pos x.stop + (x.stop.off - x.stop.bol) x.ghost; +value dump f x = + fprintf f "[%S: %d:%d-%d %d:%d%t]" + x.file_name x.start.line (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) + (fun o -> if x.ghost then fprintf o " (ghost)" else ()); + +value start_pos = { line = 1 ; bol = 0 ; off = 0 }; + +value ghost = + { file_name = "ghost-location"; + start = start_pos; + stop = start_pos; + ghost = True }; + +value mk file_name = + debug loc "mk %s@\n" file_name in + { file_name = file_name; + start = start_pos; + stop = start_pos; + ghost = False }; + +value of_tuple (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost) = + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost }; + +value to_tuple + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost } = + (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost); + +value pos_of_lexing_position p = + let pos = + { line = p.Lexing.pos_lnum ; + bol = p.Lexing.pos_bol ; + off = p.Lexing.pos_cnum } in + debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in + pos; + +value pos_to_lexing_position p file_name = + (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) + { Lexing. + pos_fname = file_name; + pos_lnum = p.line ; + pos_bol = p.bol ; + pos_cnum = p.off }; + +value better_file_name a b = + match (a, b) with + [ ("", "") -> a + | ("", x) -> x + | (x, "") -> x + | ("-", x) -> x + | (x, "-") -> x + | (x, _) -> x ]; + +value of_lexbuf lb = + let start = Lexing.lexeme_start_p lb + and stop = Lexing.lexeme_end_p lb in + let loc = + { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; + start = pos_of_lexing_position start; + stop = pos_of_lexing_position stop; + ghost = False } in + debug loc "of_lexbuf: %a@\n" dump loc in + loc; + +value of_lexing_position pos = + let loc = + { file_name = pos.Lexing.pos_fname; + start = pos_of_lexing_position pos; + stop = pos_of_lexing_position pos; + ghost = False } in + debug loc "of_lexing_position: %a@\n" dump loc in + loc; + +value to_ocaml_location x = + debug loc "to_ocaml_location: %a@\n" dump x in + { Camlp4_import.Location. + loc_start = pos_to_lexing_position x.start x.file_name; + loc_end = pos_to_lexing_position x.stop x.file_name; + loc_ghost = x.ghost }; + +value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = + let res = + { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; + start = pos_of_lexing_position a; + stop = pos_of_lexing_position b; + ghost = g } in + debug loc "of_ocaml_location: %a@\n" dump res in + res; + +value start_pos x = pos_to_lexing_position x.start x.file_name; +value stop_pos x = pos_to_lexing_position x.stop x.file_name; + +value merge a b = + if a == b then + debug loc "trivial merge@\n" in + a + else + let r = + match (a.ghost, b.ghost) with + [ (False, False) -> + (* FIXME if a.file_name <> b.file_name then + raise (Invalid_argument + (sprintf "Loc.merge: Filenames must be equal: %s <> %s" + a.file_name b.file_name)) *) + (* else *) + { (a) with stop = b.stop } + | (True, True) -> { (a) with stop = b.stop } + | (True, _) -> { (a) with stop = b.stop } + | (_, True) -> { (b) with start = a.start } ] + in debug loc "@[<hov 6>merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; + +value join x = { (x) with stop = x.start }; + +value map f start_stop_both x = + match start_stop_both with + [ `start -> { (x) with start = f x.start } + | `stop -> { (x) with stop = f x.stop } + | `both -> { (x) with start = f x.start; stop = f x.stop } ]; + +value move_pos chars x = { (x) with off = x.off + chars }; + +value move s chars x = + debug loc "move %a %d %a@\n" dump_sel s chars dump x in + map (move_pos chars) s x; + +value move_line lines x = + debug loc "move_line %d %a@\n" lines dump x in + let move_line_pos x = + { (x) with line = x.line + lines ; bol = x.off } + in map move_line_pos `both x; + +value shift width x = + { (x) with start = x.stop ; stop = move_pos width x.stop }; + +value file_name x = x.file_name; +value start_line x = x.start.line; +value stop_line x = x.stop.line; +value start_bol x = x.start.bol; +value stop_bol x = x.stop.bol; +value start_off x = x.start.off; +value stop_off x = x.stop.off; +value is_ghost x = x.ghost; + +value set_file_name s x = + debug loc "set_file_name: %a@\n" dump x in + { (x) with file_name = s }; + +value ghostify x = + debug loc "ghostify: %a@\n" dump x in + { (x) with ghost = True }; + +value make_absolute x = + debug loc "make_absolute: %a@\n" dump x in + let pwd = Sys.getcwd () in + if Filename.is_relative x.file_name then + { (x) with file_name = Filename.concat pwd x.file_name } + else x; + +value strictly_before x y = + let b = x.stop.off < y.start.off && x.file_name = y.file_name in + debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in + b; + +value to_string x = do { + let (a, b) = (x.start, x.stop) in + let res = sprintf "File \"%s\", line %d, characters %d-%d" + x.file_name a.line (a.off - a.bol) (b.off - a.bol) in + if x.start.line <> x.stop.line then + sprintf "%s (end at line %d, character %d)" + res x.stop.line (b.off - b.bol) + else res +}; + +value print out x = pp_print_string out (to_string x); + +value check x msg = + if ((start_line x) > (stop_line x) || + (start_bol x) > (stop_bol x) || + (start_off x) > (stop_off x) || + (start_line x) < 0 || (stop_line x) < 0 || + (start_bol x) < 0 || (stop_bol x) < 0 || + (start_off x) < 0 || (stop_off x) < 0) + (* Here, we don't check + (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) + since the lexer is called on antiquotations, with off=0, but line and bolpos + have "correct" values *) + then do { + eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; + False + } + else True; + +exception Exc_located of t and exn; + +ErrorHandler.register + (fun ppf -> + fun [ Exc_located loc exn -> + fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn + | exn -> raise exn ]); + +value name = ref "_loc"; + +value raise loc exc = + match exc with + [ Exc_located _ _ -> raise exc + | _ -> raise (Exc_located loc exc) ] +; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.mli new file mode 100644 index 0000000000..e90161938c --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Loc.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* 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 + *) +include Sig.Loc; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Quotation.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Quotation.ml new file mode 100644 index 0000000000..65202c8751 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Quotation.ml @@ -0,0 +1,167 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-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 (Ast : Sig.Camlp4Ast) +: Sig.Quotation with module Ast = Ast += struct + module Ast = Ast; + module DynAst = DynAst.Make Ast; + module Loc = Ast.Loc; + open Format; + open Sig; + + type expand_fun 'a = Loc.t -> option string -> string -> 'a; + + module Exp_key = DynAst.Pack(struct + type t 'a = unit; + end); + + module Exp_fun = DynAst.Pack(struct + type t 'a = expand_fun 'a; + end); + + value expanders_table = + (ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack))); + + value default = ref ""; + value translate = ref (fun x -> x); + + value expander_name name = + match translate.val name with + [ "" -> default.val + | name -> name ]; + + value find name tag = + let key = (expander_name name, Exp_key.pack tag ()) in + Exp_fun.unpack tag (List.assoc key expanders_table.val); + + value add name tag f = + let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in + expanders_table.val := [elt :: expanders_table.val]; + + value dump_file = ref None; + + module Error = struct + type error = + [ Finding + | Expanding + | ParsingResult of Loc.t and string + | Locating ]; + type t = (string * string * error * exn); + exception E of t; + + value print ppf (name, position, ctx, exn) = + let name = if name = "" then default.val else name in + let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in + let () = + match ctx with + [ Finding -> begin + pp "finding quotation"; + if expanders_table.val = [] then + fprintf ppf "@ There is no quotation expander available." + else + begin + fprintf ppf "@ @[<hv2>Available quotation expanders are:@\n"; + List.iter begin fun ((s,t),_) -> + fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " + s Exp_key.print_tag t + end expanders_table.val; + fprintf ppf "@]" + end + end + | Expanding -> pp "expanding quotation" + | Locating -> pp "parsing" + | ParsingResult loc str -> + let () = pp "parsing result of quotation" in + match dump_file.val with + [ Some dump_file -> + let () = fprintf ppf " dumping result...\n" in + try + let oc = open_out_bin dump_file in + begin + output_string oc str; + output_string oc "\n"; + flush oc; + close_out oc; + fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc); + end + with _ -> + fprintf ppf + "Error while dumping result in file %S; dump aborted" + dump_file + | None -> + fprintf ppf + "\n(consider setting variable Quotation.dump_file, or using the -QD option)" + ] + ] + in fprintf ppf "@\n%a@]@." ErrorHandler.print exn; + + value to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b; + end; + let module M = ErrorHandler.Register Error in (); + open Error; + + value expand_quotation loc expander pos_tag quot = + debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in + let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in + try expander loc loc_name_opt quot.q_contents with + [ Loc.Exc_located _ (Error.E _) as exc -> + raise exc + | Loc.Exc_located iloc exc -> + let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in + raise (Loc.Exc_located iloc exc1) + | exc -> + let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in + raise (Loc.Exc_located loc exc1) ]; + + value parse_quotation_result parse loc quot pos_tag str = + try parse loc str with + [ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) -> + let ctx = ParsingResult iloc quot.q_contents in + let exc1 = Error.E (n, pos_tag, ctx, exc) in + raise (Loc.Exc_located iloc exc1) + | Loc.Exc_located iloc (Error.E _ as exc) -> + raise (Loc.Exc_located iloc exc) + | Loc.Exc_located iloc exc -> + let ctx = ParsingResult iloc quot.q_contents in + let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in + raise (Loc.Exc_located iloc exc1) ]; + + value expand loc quotation tag = + let pos_tag = DynAst.string_of_tag tag in + let name = quotation.q_name in + debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in + let expander = + try find name tag + with + [ Loc.Exc_located _ (Error.E _) as exc -> raise exc + | Loc.Exc_located qloc exc -> + raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc))) + | exc -> + raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ] + in + let loc = Loc.join (Loc.move `start quotation.q_shift loc) in + expand_quotation loc expander pos_tag quotation; + +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.ml b/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.ml new file mode 100644 index 0000000000..384bba9116 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.ml @@ -0,0 +1,244 @@ +(****************************************************************************) +(* *) +(* 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: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Make (Loc : Sig.Loc) +: Sig.Camlp4Token with module Loc = Loc += struct + module Loc = Loc; + open Sig; + type t = camlp4_token; + type token = t; + + value to_string = + fun + [ KEYWORD s -> sprintf "KEYWORD %S" s + | SYMBOL s -> sprintf "SYMBOL %S" s + | LIDENT s -> sprintf "LIDENT %S" s + | UIDENT s -> sprintf "UIDENT %S" s + | INT _ s -> sprintf "INT %s" s + | INT32 _ s -> sprintf "INT32 %sd" s + | INT64 _ s -> sprintf "INT64 %sd" s + | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s + | FLOAT _ s -> sprintf "FLOAT %s" s + | CHAR _ s -> sprintf "CHAR '%s'" s + | STRING _ s -> sprintf "STRING \"%s\"" s + (* here it's not %S since the string is already escaped *) + | LABEL s -> sprintf "LABEL %S" s + | OPTLABEL s -> sprintf "OPTLABEL %S" s + | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s + | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" + x.q_name x.q_loc x.q_shift x.q_contents + | COMMENT s -> sprintf "COMMENT %S" s + | BLANKS s -> sprintf "BLANKS %S" s + | NEWLINE -> sprintf "NEWLINE" + | EOI -> sprintf "EOI" + | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s + | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i + | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ]; + + value print ppf x = pp_print_string ppf (to_string x); + + value match_keyword kwd = + fun + [ KEYWORD kwd' when kwd = kwd' -> True + | _ -> False ]; + + value extract_string = + fun + [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s | + INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s | + LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s + | tok -> + invalid_arg ("Cannot extract a string from this token: "^ + to_string tok) ]; + + module Error = struct + type t = + [ Illegal_token of string + | Keyword_as_label of string + | Illegal_token_pattern of string and string + | Illegal_constructor of string ]; + + exception E of t; + + value print ppf = + fun + [ Illegal_token s -> + fprintf ppf "Illegal token (%s)" s + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd + | Illegal_token_pattern p_con p_prm -> + fprintf ppf "Illegal token pattern: %s %S" p_con p_prm + | Illegal_constructor con -> + fprintf ppf "Illegal constructor %S" con ]; + + value to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b; + end; + let module M = ErrorHandler.Register Error in (); + + module Filter = struct + type token_filter = stream_filter t Loc.t; + + type t = + { is_kwd : string -> bool; + filter : mutable token_filter }; + + value err error loc = + raise (Loc.Exc_located loc (Error.E error)); + + value keyword_conversion tok is_kwd = + match tok with + [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s + | ESCAPED_IDENT s -> LIDENT s + | _ -> tok ]; + + value check_keyword_as_label tok loc is_kwd = + let s = + match tok with + [ LABEL s -> s + | OPTLABEL s -> s + | _ -> "" ] + in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else (); + + value check_unknown_keywords tok loc = + match tok with + [ SYMBOL s -> err (Error.Illegal_token s) loc + | _ -> () ]; + + value error_no_respect_rules p_con p_prm = + raise (Error.E (Error.Illegal_token_pattern p_con p_prm)); + + value check_keyword _ = True; + (* FIXME let lb = Lexing.from_string s in + let next () = token default_context lb in + try + match next () with + [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI) + | _ -> False ] + with [ Stream.Error _ -> False ]; *) + + value error_on_unknown_keywords = ref False; + + value rec ignore_layout = + parser + [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] -> + ignore_layout s + | [: ` x; s :] -> [: ` x; ignore_layout s :] + | [: :] -> [: :] ]; + + value mk is_kwd = + { is_kwd = is_kwd; + filter = ignore_layout }; + + value filter x = + let f tok loc = do { + let tok = keyword_conversion tok x.is_kwd; + check_keyword_as_label tok loc x.is_kwd; + if error_on_unknown_keywords.val + then check_unknown_keywords tok loc else (); + debug token "@[<hov 2>Lexer before filter:@ %a@ at@ %a@]@." + print tok Loc.dump loc in + (tok, loc) + } in + let rec filter = + parser + [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :] + | [: :] -> [: :] ] + in + let rec tracer = (* FIXME add a debug block construct *) + parser + [ [: `((_tok, _loc) as x); xs :] -> + debug token "@[<hov 2>Lexer after filter:@ %a@ at@ %a@]@." + print _tok Loc.dump _loc in + [: ` x; tracer xs :] + | [: :] -> [: :] ] + in fun strm -> tracer (x.filter (filter strm)); + + value define_filter x f = x.filter := f x.filter; + + value keyword_added _ _ _ = (); + value keyword_removed _ _ = (); + end; + +end; + +(* Char and string tokens to real chars and string *) +module Eval = struct + + value valch x = Char.code x - Char.code '0'; + value valch_hex x = + let d = Char.code x in + if d >= 97 then d - 87 + else if d >= 65 then d - 55 + else d - 48; + + value rec skip_indent = parser + [ [: `' ' | '\t'; s :] -> skip_indent s + | [: :] -> () ]; + + value skip_opt_linefeed = parser + [ [: `'\010' :] -> () + | [: :] -> () ]; + + value chr c = + if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c; + + value rec backslash = parser + [ [: `'\010' :] -> '\010' + | [: `'\013' :] -> '\013' + | [: `'n' :] -> '\n' + | [: `'r' :] -> '\r' + | [: `'t' :] -> '\t' + | [: `'b' :] -> '\b' + | [: `'\\' :] -> '\\' + | [: `'"' :] -> '"' + | [: `''' :] -> ''' + | [: `' ' :] -> ' ' + | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> + chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) + | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ; + `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] -> + chr (16 * (valch_hex c1) + (valch_hex c2)) ]; + + value rec backslash_in_string strict store = parser + [ [: `'\010'; s :] -> skip_indent s + | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s } + | [: x = backslash :] -> store x + | [: `c when not strict :] -> do { store '\\'; store c } + | [: :] -> failwith "invalid string token" ]; + + value char s = + if String.length s = 1 then s.[0] + else if String.length s = 0 then failwith "invalid char token" + else match Stream.of_string s with parser + [ [: `'\\'; x = backslash :] -> x + | [: :] -> failwith "invalid char token" ]; + + value string ?strict s = + let buf = Buffer.create 23 in + let store = Buffer.add_char buf in + let rec parse = parser + [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s + | [: `c; s :] -> do { store c; parse s } + | [: :] -> Buffer.contents buf ] + in parse (Stream.of_string s); +end; diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.mli b/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.mli new file mode 100644 index 0000000000..812df0e008 --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Token.mli @@ -0,0 +1,35 @@ +(****************************************************************************) +(* *) +(* 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.Camlp4Token with module Loc = Loc; + +module Eval : sig + value char : string -> char; + (** Convert a char token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if an + incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)] + returns [c] *) + + value string : ?strict:unit -> string -> string; + (** [Taken.Eval.string strict s] + Convert a string token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if [strict] and an + incorrect backslash sequence is found; + [Token.Eval.string strict (String.escaped s)] returns [s] *) +end; |