535 lines
16 KiB
Plaintext
535 lines
16 KiB
Plaintext
(****************************************************************************)
|
|
(* *)
|
|
(* 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< ($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< ($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
|
|
| _ -> 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;
|