(* ------------------------------------------------------------------------- *)
(* New version. *)
(* ------------------------------------------------------------------------- *)
(* camlp5r *)
(* $Id: pa_o.ml,v 6.33 2010-11-16 16:48:21 deraugla Exp $ *)
(* Copyright (c) INRIA 2007-2010 *)
#load "pa_extend.cmo";
#load "q_MLast.cmo";
#load "pa_reloc.cmo";
open Pcaml;
Pcaml.syntax_name.val := "OCaml";
Pcaml.no_constructors_arity.val := True;
(* ------------------------------------------------------------------------- *)
(* The main/reloc.ml file. *)
(* ------------------------------------------------------------------------- *)
(* camlp5r *)
(* $Id: reloc.ml,v 6.16 2010-11-21 17:17:45 deraugla Exp $ *)
(* Copyright (c) INRIA 2007-2010 *)
#load "pa_macro.cmo";
open MLast;
value option_map f =
fun
[ Some x -> Some (f x)
| None -> None ]
;
value vala_map f =
IFNDEF STRICT THEN
fun x -> f x
ELSE
fun
[ Ploc.VaAnt s -> Ploc.VaAnt s
| Ploc.VaVal x -> Ploc.VaVal (f x) ]
END
;
value class_infos_map floc f x =
{ciLoc = floc x.ciLoc; ciVir = x.ciVir;
ciPrm =
let (x1, x2) = x.ciPrm in
(floc x1, x2);
ciNam = x.ciNam; ciExp = f x.ciExp}
;
value anti_loc qloc sh loc loc1 =
(*
...<:expr<.....$lid:...xxxxxxxx...$...>>...
|..|-----------------------------------| qloc
<-----> sh
|.........|------------| loc
|..|------| loc1
*)
let sh1 = Ploc.first_pos qloc + sh in
let sh2 = sh1 + Ploc.first_pos loc in
let line_nb_qloc = Ploc.line_nb qloc in
let line_nb_loc = Ploc.line_nb loc in
let line_nb_loc1 = Ploc.line_nb loc1 in
if line_nb_qloc < 0 || line_nb_loc < 0 || line_nb_loc1 < 0 then
Ploc.make_unlined
(sh2 + Ploc.first_pos loc1, sh2 + Ploc.last_pos loc1)
else
Ploc.make_loc (Ploc.file_name loc)
(line_nb_qloc + line_nb_loc + line_nb_loc1 - 2)
(if line_nb_loc1 = 1 then
if line_nb_loc = 1 then Ploc.bol_pos qloc
else sh1 + Ploc.bol_pos loc
else sh2 + Ploc.bol_pos loc1)
(sh2 + Ploc.first_pos loc1, sh2 + Ploc.last_pos loc1) ""
;
value rec reloc_ctyp floc sh =
self where rec self =
fun
[ TyAcc loc x1 x2 ->
let loc = floc loc in
TyAcc loc (self x1) (self x2)
| TyAli loc x1 x2 ->
let loc = floc loc in
TyAli loc (self x1) (self x2)
| TyAny loc ->
let loc = floc loc in
TyAny loc
| TyApp loc x1 x2 ->
let loc = floc loc in
TyApp loc (self x1) (self x2)
| TyArr loc x1 x2 ->
let loc = floc loc in
TyArr loc (self x1) (self x2)
| TyCls loc x1 ->
let loc = floc loc in
TyCls loc x1
| TyLab loc x1 x2 ->
let loc = floc loc in
TyLab loc x1 (self x2)
| TyLid loc x1 ->
let loc = floc loc in
TyLid loc x1
| TyMan loc x1 x2 x3 ->
let loc = floc loc in
TyMan loc (self x1) x2 (self x3)
| TyObj loc x1 x2 ->
let loc = floc loc in
TyObj loc (vala_map (List.map (fun (x1, x2) -> (x1, self x2))) x1) x2
| TyOlb loc x1 x2 ->
let loc = floc loc in
TyOlb loc x1 (self x2)
| TyPck loc x1 ->
let loc = floc loc in
TyPck loc (reloc_module_type floc sh x1)
| TyPol loc x1 x2 ->
let loc = floc loc in
TyPol loc x1 (self x2)
| TyPot loc x1 x2 ->
let loc = floc loc in
TyPot loc x1 (self x2)
| TyQuo loc x1 ->
let loc = floc loc in
TyQuo loc x1
| TyRec loc x1 ->
let loc = floc loc in
TyRec loc
(vala_map
(List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)))
x1)
| TySum loc x1 ->
let loc = floc loc in
TySum loc
(vala_map
(List.map
(fun (loc, x1, x2, x3) ->
(floc loc, x1, vala_map (List.map self) x2,
option_map self x3)))
x1)
| TyTup loc x1 ->
let loc = floc loc in
TyTup loc (vala_map (List.map self) x1)
| TyUid loc x1 ->
let loc = floc loc in
TyUid loc x1
| TyVrn loc x1 x2 ->
let loc = floc loc in
TyVrn loc (vala_map (List.map (reloc_poly_variant floc sh)) x1) x2
| IFDEF STRICT THEN
TyXtr loc x1 x2 ->
let loc = floc loc in
TyXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_poly_variant floc sh =
fun
[ PvTag loc x1 x2 x3 ->
let loc = floc loc in
PvTag loc x1 x2 (vala_map (List.map (reloc_ctyp floc sh)) x3)
| PvInh loc x1 ->
let loc = floc loc in
PvInh loc (reloc_ctyp floc sh x1) ]
and reloc_patt floc sh =
self where rec self =
fun
[ PaAcc loc x1 x2 ->
let loc = floc loc in
PaAcc loc (self x1) (self x2)
| PaAli loc x1 x2 ->
let loc = floc loc in
PaAli loc (self x1) (self x2)
| PaAnt loc x1 ->
let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
reloc_patt new_floc sh x1
| PaAny loc ->
let loc = floc loc in
PaAny loc
| PaApp loc x1 x2 ->
let loc = floc loc in
PaApp loc (self x1) (self x2)
| PaArr loc x1 ->
let loc = floc loc in
PaArr loc (vala_map (List.map self) x1)
| PaChr loc x1 ->
let loc = floc loc in
PaChr loc x1
| PaFlo loc x1 ->
let loc = floc loc in
PaFlo loc x1
| PaInt loc x1 x2 ->
let loc = floc loc in
PaInt loc x1 x2
| PaLab loc x1 x2 ->
let loc = floc loc in
PaLab loc (self x1) (vala_map (option_map self) x2)
| PaLaz loc x1 ->
let loc = floc loc in
PaLaz loc (self x1)
| PaLid loc x1 ->
let loc = floc loc in
PaLid loc x1
| PaNty loc x1 ->
let loc = floc loc in
PaNty loc x1
| PaOlb loc x1 x2 ->
let loc = floc loc in
PaOlb loc (self x1) (vala_map (option_map (reloc_expr floc sh)) x2)
| PaOrp loc x1 x2 ->
let loc = floc loc in
PaOrp loc (self x1) (self x2)
| PaRec loc x1 ->
let loc = floc loc in
PaRec loc
(vala_map (List.map (fun (x1, x2) -> (self x1, self x2))) x1)
| PaRng loc x1 x2 ->
let loc = floc loc in
PaRng loc (self x1) (self x2)
| PaStr loc x1 ->
let loc = floc loc in
PaStr loc x1
| PaTup loc x1 ->
let loc = floc loc in
PaTup loc (vala_map (List.map self) x1)
| PaTyc loc x1 x2 ->
let loc = floc loc in
PaTyc loc (self x1) (reloc_ctyp floc sh x2)
| PaTyp loc x1 ->
let loc = floc loc in
PaTyp loc x1
| PaUid loc x1 ->
let loc = floc loc in
PaUid loc x1
| PaUnp loc x1 x2 ->
let loc = floc loc in
PaUnp loc x1 (option_map (reloc_module_type floc sh) x2)
| PaVrn loc x1 ->
let loc = floc loc in
PaVrn loc x1
| IFDEF STRICT THEN
PaXtr loc x1 x2 ->
let loc = floc loc in
PaXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_expr floc sh =
self where rec self =
fun
[ ExAcc loc x1 x2 ->
let loc = floc loc in
ExAcc loc (self x1) (self x2)
| ExAnt loc x1 ->
let new_floc loc1 = anti_loc (floc loc) sh loc loc1 in
reloc_expr new_floc sh x1
| ExApp loc x1 x2 ->
let loc = floc loc in
ExApp loc (self x1) (self x2)
| ExAre loc x1 x2 ->
let loc = floc loc in
ExAre loc (self x1) (self x2)
| ExArr loc x1 ->
let loc = floc loc in
ExArr loc (vala_map (List.map self) x1)
| ExAsr loc x1 ->
let loc = floc loc in
ExAsr loc (self x1)
| ExAss loc x1 x2 ->
let loc = floc loc in
ExAss loc (self x1) (self x2)
| ExBae loc x1 x2 ->
let loc = floc loc in
ExBae loc (self x1) (vala_map (List.map self) x2)
| ExChr loc x1 ->
let loc = floc loc in
ExChr loc x1
| ExCoe loc x1 x2 x3 ->
let loc = floc loc in
ExCoe loc (self x1) (option_map (reloc_ctyp floc sh) x2) (reloc_ctyp floc sh x3)
| ExFlo loc x1 ->
let loc = floc loc in
ExFlo loc x1
| ExFor loc x1 x2 x3 x4 x5 ->
let loc = floc loc in
ExFor loc x1 (self x2) (self x3) x4 (vala_map (List.map self) x5)
| ExFun loc x1 ->
let loc = floc loc in
ExFun loc
(vala_map
(List.map
(fun (x1, x2, x3) ->
(reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
x1)
| ExIfe loc x1 x2 x3 ->
let loc = floc loc in
ExIfe loc (self x1) (self x2) (self x3)
| ExInt loc x1 x2 ->
let loc = floc loc in
ExInt loc x1 x2
| ExLab loc x1 ->
let loc = floc loc in
ExLab loc
(vala_map
(List.map
(fun (x1, x2) ->
(reloc_patt floc sh x1, vala_map (option_map self) x2)))
x1)
| ExLaz loc x1 ->
let loc = floc loc in
ExLaz loc (self x1)
| ExLet loc x1 x2 x3 ->
let loc = floc loc in
ExLet loc x1
(vala_map (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, self x2)))
x2)
(self x3)
| ExLid loc x1 ->
let loc = floc loc in
ExLid loc x1
| ExLmd loc x1 x2 x3 ->
let loc = floc loc in
ExLmd loc x1 (reloc_module_expr floc sh x2) (self x3)
| ExMat loc x1 x2 ->
let loc = floc loc in
ExMat loc (self x1)
(vala_map
(List.map
(fun (x1, x2, x3) ->
(reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
x2)
| ExNew loc x1 ->
let loc = floc loc in
ExNew loc x1
| ExObj loc x1 x2 ->
let loc = floc loc in
ExObj loc (vala_map (option_map (reloc_patt floc sh)) x1)
(vala_map (List.map (reloc_class_str_item floc sh)) x2)
| ExOlb loc x1 x2 ->
let loc = floc loc in
ExOlb loc (reloc_patt floc sh x1) (vala_map (option_map self) x2)
| ExOvr loc x1 ->
let loc = floc loc in
ExOvr loc (vala_map (List.map (fun (x1, x2) -> (x1, self x2))) x1)
| ExPck loc x1 x2 ->
let loc = floc loc in
ExPck loc (reloc_module_expr floc sh x1)
(option_map (reloc_module_type floc sh) x2)
| ExRec loc x1 x2 ->
let loc = floc loc in
ExRec loc
(vala_map (List.map (fun (x1, x2) -> (reloc_patt floc sh x1, self x2)))
x1)
(option_map self x2)
| ExSeq loc x1 ->
let loc = floc loc in
ExSeq loc (vala_map (List.map self) x1)
| ExSnd loc x1 x2 ->
let loc = floc loc in
ExSnd loc (self x1) x2
| ExSte loc x1 x2 ->
let loc = floc loc in
ExSte loc (self x1) (self x2)
| ExStr loc x1 ->
let loc = floc loc in
ExStr loc x1
| ExTry loc x1 x2 ->
let loc = floc loc in
ExTry loc (self x1)
(vala_map
(List.map
(fun (x1, x2, x3) ->
(reloc_patt floc sh x1, vala_map (option_map self) x2, self x3)))
x2)
| ExTup loc x1 ->
let loc = floc loc in
ExTup loc (vala_map (List.map self) x1)
| ExTyc loc x1 x2 ->
let loc = floc loc in
ExTyc loc (self x1) (reloc_ctyp floc sh x2)
| ExUid loc x1 ->
let loc = floc loc in
ExUid loc x1
| ExVrn loc x1 ->
let loc = floc loc in
ExVrn loc x1
| ExWhi loc x1 x2 ->
let loc = floc loc in
ExWhi loc (self x1) (vala_map (List.map self) x2)
| IFDEF STRICT THEN
ExXtr loc x1 x2 ->
let loc = floc loc in
ExXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_module_type floc sh =
self where rec self =
fun
[ MtAcc loc x1 x2 ->
let loc = floc loc in
MtAcc loc (self x1) (self x2)
| MtApp loc x1 x2 ->
let loc = floc loc in
MtApp loc (self x1) (self x2)
| MtFun loc x1 x2 x3 ->
let loc = floc loc in
MtFun loc x1 (self x2) (self x3)
| MtLid loc x1 ->
let loc = floc loc in
MtLid loc x1
| MtQuo loc x1 ->
let loc = floc loc in
MtQuo loc x1
| MtSig loc x1 ->
let loc = floc loc in
MtSig loc (vala_map (List.map (reloc_sig_item floc sh)) x1)
| MtTyo loc x1 ->
let loc = floc loc in
MtTyo loc (reloc_module_expr floc sh x1)
| MtUid loc x1 ->
let loc = floc loc in
MtUid loc x1
| MtWit loc x1 x2 ->
let loc = floc loc in
MtWit loc (self x1) (vala_map (List.map (reloc_with_constr floc sh)) x2)
| IFDEF STRICT THEN
MtXtr loc x1 x2 ->
let loc = floc loc in
MtXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_sig_item floc sh =
self where rec self =
fun
[ SgCls loc x1 ->
let loc = floc loc in
SgCls loc
(vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
| SgClt loc x1 ->
let loc = floc loc in
SgClt loc
(vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
| SgDcl loc x1 ->
let loc = floc loc in
SgDcl loc (vala_map (List.map self) x1)
| SgDir loc x1 x2 ->
let loc = floc loc in
SgDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
| SgExc loc x1 x2 ->
let loc = floc loc in
SgExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
| SgExt loc x1 x2 x3 ->
let loc = floc loc in
SgExt loc x1 (reloc_ctyp floc sh x2) x3
| SgInc loc x1 ->
let loc = floc loc in
SgInc loc (reloc_module_type floc sh x1)
| SgMod loc x1 x2 ->
let loc = floc loc in
SgMod loc x1
(vala_map (List.map (fun (x1, x2) -> (x1, reloc_module_type floc sh x2)))
x2)
| SgMty loc x1 x2 ->
let loc = floc loc in
SgMty loc x1 (reloc_module_type floc sh x2)
| SgOpn loc x1 ->
let loc = floc loc in
SgOpn loc x1
| SgTyp loc x1 ->
let loc = floc loc in
SgTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
| SgUse loc x1 x2 ->
let loc = floc loc in
SgUse loc x1
(vala_map (List.map (fun (x1, loc) -> (self x1, floc loc))) x2)
| SgVal loc x1 x2 ->
let loc = floc loc in
SgVal loc x1 (reloc_ctyp floc sh x2)
| IFDEF STRICT THEN
SgXtr loc x1 x2 ->
let loc = floc loc in
SgXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_with_constr floc sh =
fun
[ WcMod loc x1 x2 ->
let loc = floc loc in
WcMod loc x1 (reloc_module_expr floc sh x2)
| WcMos loc x1 x2 ->
let loc = floc loc in
WcMos loc x1 (reloc_module_expr floc sh x2)
| WcTyp loc x1 x2 x3 x4 ->
let loc = floc loc in
WcTyp loc x1 x2 x3 (reloc_ctyp floc sh x4)
| WcTys loc x1 x2 x3 ->
let loc = floc loc in
WcTys loc x1 x2 (reloc_ctyp floc sh x3) ]
and reloc_module_expr floc sh =
self where rec self =
fun
[ MeAcc loc x1 x2 ->
let loc = floc loc in
MeAcc loc (self x1) (self x2)
| MeApp loc x1 x2 ->
let loc = floc loc in
MeApp loc (self x1) (self x2)
| MeFun loc x1 x2 x3 ->
let loc = floc loc in
MeFun loc x1 (reloc_module_type floc sh x2) (self x3)
| MeStr loc x1 ->
let loc = floc loc in
MeStr loc (vala_map (List.map (reloc_str_item floc sh)) x1)
| MeTyc loc x1 x2 ->
let loc = floc loc in
MeTyc loc (self x1) (reloc_module_type floc sh x2)
| MeUid loc x1 ->
let loc = floc loc in
MeUid loc x1
| MeUnp loc x1 x2 ->
let loc = floc loc in
MeUnp loc (reloc_expr floc sh x1) (option_map (reloc_module_type floc sh) x2)
| IFDEF STRICT THEN
MeXtr loc x1 x2 ->
let loc = floc loc in
MeXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_str_item floc sh =
self where rec self =
fun
[ StCls loc x1 ->
let loc = floc loc in
StCls loc
(vala_map (List.map (class_infos_map floc (reloc_class_expr floc sh))) x1)
| StClt loc x1 ->
let loc = floc loc in
StClt loc
(vala_map (List.map (class_infos_map floc (reloc_class_type floc sh))) x1)
| StDcl loc x1 ->
let loc = floc loc in
StDcl loc (vala_map (List.map self) x1)
| StDir loc x1 x2 ->
let loc = floc loc in
StDir loc x1 (vala_map (option_map (reloc_expr floc sh)) x2)
| StExc loc x1 x2 x3 ->
let loc = floc loc in
StExc loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2) x3
| StExp loc x1 ->
let loc = floc loc in
StExp loc (reloc_expr floc sh x1)
| StExt loc x1 x2 x3 ->
let loc = floc loc in
StExt loc x1 (reloc_ctyp floc sh x2) x3
| StInc loc x1 ->
let loc = floc loc in
StInc loc (reloc_module_expr floc sh x1)
| StMod loc x1 x2 ->
let loc = floc loc in
StMod loc x1
(vala_map (List.map (fun (x1, x2) -> (x1, reloc_module_expr floc sh x2)))
x2)
| StMty loc x1 x2 ->
let loc = floc loc in
StMty loc x1 (reloc_module_type floc sh x2)
| StOpn loc x1 ->
let loc = floc loc in
StOpn loc x1
| StTyp loc x1 ->
let loc = floc loc in
StTyp loc (vala_map (List.map (reloc_type_decl floc sh)) x1)
| StUse loc x1 x2 ->
let loc = floc loc in
StUse loc x1
(vala_map (List.map (fun (x1, loc) -> (self x1, floc loc))) x2)
| StVal loc x1 x2 ->
let loc = floc loc in
StVal loc x1
(vala_map
(List.map (fun (x1, x2) -> (reloc_patt floc sh x1, reloc_expr floc sh x2)))
x2)
| IFDEF STRICT THEN
StXtr loc x1 x2 ->
let loc = floc loc in
StXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_type_decl floc sh x =
{tdNam = vala_map (fun (loc, x1) -> (floc loc, x1)) x.tdNam;
tdPrm = x.tdPrm; tdPrv = x.tdPrv; tdDef = reloc_ctyp floc sh x.tdDef;
tdCon =
vala_map (List.map (fun (x1, x2) -> (reloc_ctyp floc sh x1, reloc_ctyp floc sh x2)))
x.tdCon}
and reloc_class_type floc sh =
self where rec self =
fun
[ CtAcc loc x1 x2 ->
let loc = floc loc in
CtAcc loc (self x1) (self x2)
| CtApp loc x1 x2 ->
let loc = floc loc in
CtApp loc (self x1) (self x2)
| CtCon loc x1 x2 ->
let loc = floc loc in
CtCon loc (self x1) (vala_map (List.map (reloc_ctyp floc sh)) x2)
| CtFun loc x1 x2 ->
let loc = floc loc in
CtFun loc (reloc_ctyp floc sh x1) (self x2)
| CtIde loc x1 ->
let loc = floc loc in
CtIde loc x1
| CtSig loc x1 x2 ->
let loc = floc loc in
CtSig loc (vala_map (option_map (reloc_ctyp floc sh)) x1)
(vala_map (List.map (reloc_class_sig_item floc sh)) x2)
| IFDEF STRICT THEN
CtXtr loc x1 x2 ->
let loc = floc loc in
CtXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_class_sig_item floc sh =
self where rec self =
fun
[ CgCtr loc x1 x2 ->
let loc = floc loc in
CgCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
| CgDcl loc x1 ->
let loc = floc loc in
CgDcl loc (vala_map (List.map self) x1)
| CgInh loc x1 ->
let loc = floc loc in
CgInh loc (reloc_class_type floc sh x1)
| CgMth loc x1 x2 x3 ->
let loc = floc loc in
CgMth loc x1 x2 (reloc_ctyp floc sh x3)
| CgVal loc x1 x2 x3 ->
let loc = floc loc in
CgVal loc x1 x2 (reloc_ctyp floc sh x3)
| CgVir loc x1 x2 x3 ->
let loc = floc loc in
CgVir loc x1 x2 (reloc_ctyp floc sh x3) ]
and reloc_class_expr floc sh =
self where rec self =
fun
[ CeApp loc x1 x2 ->
let loc = floc loc in
CeApp loc (self x1) (reloc_expr floc sh x2)
| CeCon loc x1 x2 ->
let loc = floc loc in
CeCon loc x1 (vala_map (List.map (reloc_ctyp floc sh)) x2)
| CeFun loc x1 x2 ->
let loc = floc loc in
CeFun loc (reloc_patt floc sh x1) (self x2)
| CeLet loc x1 x2 x3 ->
let loc = floc loc in
CeLet loc x1
(vala_map
(List.map (fun (x1, x2) -> (reloc_patt floc sh x1, reloc_expr floc sh x2)))
x2)
(self x3)
| CeStr loc x1 x2 ->
let loc = floc loc in
CeStr loc (vala_map (option_map (reloc_patt floc sh)) x1)
(vala_map (List.map (reloc_class_str_item floc sh)) x2)
| CeTyc loc x1 x2 ->
let loc = floc loc in
CeTyc loc (self x1) (reloc_class_type floc sh x2)
| IFDEF STRICT THEN
CeXtr loc x1 x2 ->
let loc = floc loc in
CeXtr loc x1 (option_map (vala_map self) x2)
END ]
and reloc_class_str_item floc sh =
self where rec self =
fun
[ CrCtr loc x1 x2 ->
let loc = floc loc in
CrCtr loc (reloc_ctyp floc sh x1) (reloc_ctyp floc sh x2)
| CrDcl loc x1 ->
let loc = floc loc in
CrDcl loc (vala_map (List.map self) x1)
| CrInh loc x1 x2 ->
let loc = floc loc in
CrInh loc (reloc_class_expr floc sh x1) x2
| CrIni loc x1 ->
let loc = floc loc in
CrIni loc (reloc_expr floc sh x1)
| CrMth loc x1 x2 x3 x4 x5 ->
let loc = floc loc in
CrMth loc x1 x2 x3 (vala_map (option_map (reloc_ctyp floc sh)) x4)
(reloc_expr floc sh x5)
| CrVal loc x1 x2 x3 x4 ->
let loc = floc loc in
CrVal loc x1 x2 x3 (reloc_expr floc sh x4)
| CrVav loc x1 x2 x3 ->
let loc = floc loc in
CrVav loc x1 x2 (reloc_ctyp floc sh x3)
| CrVir loc x1 x2 x3 ->
let loc = floc loc in
CrVir loc x1 x2 (reloc_ctyp floc sh x3) ]
;
(* Equality over syntax trees *)
value eq_expr x y =
reloc_expr (fun _ -> Ploc.dummy) 0 x =
reloc_expr (fun _ -> Ploc.dummy) 0 y
;
value eq_patt x y =
reloc_patt (fun _ -> Ploc.dummy) 0 x =
reloc_patt (fun _ -> Ploc.dummy) 0 y
;
value eq_ctyp x y =
reloc_ctyp (fun _ -> Ploc.dummy) 0 x =
reloc_ctyp (fun _ -> Ploc.dummy) 0 y
;
value eq_str_item x y =
reloc_str_item (fun _ -> Ploc.dummy) 0 x =
reloc_str_item (fun _ -> Ploc.dummy) 0 y
;
value eq_sig_item x y =
reloc_sig_item (fun _ -> Ploc.dummy) 0 x =
reloc_sig_item (fun _ -> Ploc.dummy) 0 y
;
value eq_module_expr x y =
reloc_module_expr (fun _ -> Ploc.dummy) 0 x =
reloc_module_expr (fun _ -> Ploc.dummy) 0 y
;
value eq_module_type x y =
reloc_module_type (fun _ -> Ploc.dummy) 0 x =
reloc_module_type (fun _ -> Ploc.dummy) 0 y
;
value eq_class_sig_item x y =
reloc_class_sig_item (fun _ -> Ploc.dummy) 0 x =
reloc_class_sig_item (fun _ -> Ploc.dummy) 0 y
;
value eq_class_str_item x y =
reloc_class_str_item (fun _ -> Ploc.dummy) 0 x =
reloc_class_str_item (fun _ -> Ploc.dummy) 0 y
;
value eq_class_type x y =
reloc_class_type (fun _ -> Ploc.dummy) 0 x =
reloc_class_type (fun _ -> Ploc.dummy) 0 y
;
value eq_class_expr x y =
reloc_class_expr (fun _ -> Ploc.dummy) 0 x =
reloc_class_expr (fun _ -> Ploc.dummy) 0 y
;
(* ------------------------------------------------------------------------- *)
(* Now the lexer. *)
(* ------------------------------------------------------------------------- *)
(* camlp5r *)
(* $Id: plexer.ml,v 6.11 2010-10-04 20:14:58 deraugla Exp $ *)
(* Copyright (c) INRIA 2007-2010 *)
#load "pa_lexer.cmo";
(* ------------------------------------------------------------------------- *)
(* Added by JRH as a backdoor to change lexical conventions. *)
(* ------------------------------------------------------------------------- *)
value jrh_lexer = ref False;
open Versdep;
value no_quotations = ref False;
value error_on_unknown_keywords = ref False;
value dollar_for_antiquotation = ref True;
value specific_space_dot = ref False;
value force_antiquot_loc = ref False;
type context =
{ after_space : mutable bool;
dollar_for_antiquotation : bool;
specific_space_dot : bool;
find_kwd : string -> string;
line_cnt : int -> char -> unit;
set_line_nb : unit -> unit;
make_lined_loc : (int * int) -> string -> Ploc.t }
;
value err ctx loc msg =
Ploc.raise (ctx.make_lined_loc loc "") (Plexing.Error msg)
;
(* ------------------------------------------------------------------------- *)
(* JRH's hack to make the case distinction "unmixed" versus "mixed" *)
(* ------------------------------------------------------------------------- *)
value is_uppercase s = String.uppercase s = s;
value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
value jrh_identifier find_kwd id =
let jflag = jrh_lexer.val in
if id = "set_jrh_lexer" then
(let _ = jrh_lexer.val := True in ("",find_kwd "true"))
else if id = "unset_jrh_lexer" then
(let _ = jrh_lexer.val := False in ("",find_kwd "false"))
else
try ("", find_kwd id) with
[ Not_found ->
if not(jflag) then
if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
else ("LIDENT", id)
else if is_uppercase (String.sub id 0 1) &&
is_only_lowercase (String.sub id 1 (String.length id - 1))
(***** JRH: Carl's alternative version
then ("UIDENT", id)
else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id)
else ("LIDENT", id)];
*****)
then ("UIDENT", id) else ("LIDENT", id)];
(* ------------------------------------------------------------------------- *)
(* Back to original file with the mod of using the above. *)
(* ------------------------------------------------------------------------- *)
value keyword_or_error ctx loc s =
try ("", ctx.find_kwd s) with
[ Not_found ->
if error_on_unknown_keywords.val then
err ctx loc ("illegal token: " ^ s)
else ("", s) ]
;
value stream_peek_nth n strm =
loop n (Stream.npeek n strm) where rec loop n =
fun
[ [] -> None
| [x] -> if n == 1 then Some x else None
| [_ :: l] -> loop (n - 1) l ]
;
value utf8_lexing = ref False;
value misc_letter buf strm =
if utf8_lexing.val then
match strm with lexer [ '\128'-'\225' | '\227'-'\255' ]
else
match strm with lexer [ '\128'-'\255' ]
;
value misc_punct buf strm =
if utf8_lexing.val then
match strm with lexer [ '\226' _ _ ]
else
match strm with parser []
;
value rec ident =
lexer
[ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ] ident! | ]
;
value rec ident2 =
lexer
[ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
'%' | '.' | ':' | '<' | '>' | '|' | '$' | misc_punct ]
ident2!
| ]
;
value rec ident3 =
lexer
[ [ '0'-'9' | 'A'-'Z' | 'a'-'z' | '_' | '!' | '%' | '&' | '*' | '+' | '-' |
'.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
'$' | '\128'-'\255' ] ident3!
| ]
;
value binary = lexer [ '0' | '1' ];
value octal = lexer [ '0'-'7' ];
value decimal = lexer [ '0'-'9' ];
value hexa = lexer [ '0'-'9' | 'a'-'f' | 'A'-'F' ];
value end_integer =
lexer
[ "l"/ -> ("INT_l", $buf)
| "L"/ -> ("INT_L", $buf)
| "n"/ -> ("INT_n", $buf)
| -> ("INT", $buf) ]
;
value rec digits_under kind =
lexer
[ kind (digits_under kind)!
| "_" (digits_under kind)!
| end_integer ]
;
value digits kind =
lexer
[ kind (digits_under kind)!
| -> raise (Stream.Error "ill-formed integer constant") ]
;
value rec decimal_digits_under =
lexer [ [ '0'-'9' | '_' ] decimal_digits_under! | ]
;
value exponent_part =
lexer
[ [ 'e' | 'E' ] [ '+' | '-' | ]
'0'-'9' ? "ill-formed floating-point constant"
decimal_digits_under! ]
;
value number =
lexer
[ decimal_digits_under "." decimal_digits_under! exponent_part ->
("FLOAT", $buf)
| decimal_digits_under "." decimal_digits_under! -> ("FLOAT", $buf)
| decimal_digits_under exponent_part -> ("FLOAT", $buf)
| decimal_digits_under end_integer! ]
;
value char_after_bslash =
lexer
[ "'"/
| _ [ "'"/ | _ [ "'"/ | ] ] ]
;
value char ctx bp =
lexer
[ "\\" _ char_after_bslash!
| "\\" -> err ctx (bp, $pos) "char not terminated"
| ?= [ _ '''] _! "'"/ ]
;
value any ctx buf =
parser bp [: `c :] -> do { ctx.line_cnt bp c; $add c }
;
value rec string ctx bp =
lexer
[ "\""/
| "\\" (any ctx) (string ctx bp)!
| (any ctx) (string ctx bp)!
| -> err ctx (bp, $pos) "string not terminated" ]
;
value rec qstring ctx bp =
lexer
[ "`"/
| (any ctx) (qstring ctx bp)!
| -> err ctx (bp, $pos) "quotation not terminated" ]
;
value comment ctx bp =
comment where rec comment =
lexer
[ "*)"
| "*" comment!
| "(*" comment! comment!
| "(" comment!
| "\"" (string ctx bp)! [ -> $add "\"" ] comment!
| "'*)"
| "'*" comment!
| "'" (any ctx) comment!
| (any ctx) comment!
| -> err ctx (bp, $pos) "comment not terminated" ]
;
value rec quotation ctx bp =
lexer
[ ">>"/
| ">" (quotation ctx bp)!
| "<<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
| "<:" ident! "<" (quotation ctx bp)! [ -> $add ">>" ]! (quotation ctx bp)!
| "<:" ident! (quotation ctx bp)!
| "<" (quotation ctx bp)!
| "\\"/ [ '>' | '<' | '\\' ] (quotation ctx bp)!
| "\\" (quotation ctx bp)!
| (any ctx) (quotation ctx bp)!
| -> err ctx (bp, $pos) "quotation not terminated" ]
;
value less_expected = "character '<' expected";
value less ctx bp buf strm =
if no_quotations.val then
match strm with lexer
[ [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
else
match strm with lexer
[ "<"/ (quotation ctx bp) -> ("QUOTATION", ":" ^ $buf)
| ":"/ ident! "<"/ ? less_expected [ -> $add ":" ]! (quotation ctx bp) ->
("QUOTATION", $buf)
| ":"/ ident! ":<"/ ? less_expected [ -> $add "@" ]! (quotation ctx bp) ->
("QUOTATION", $buf)
| [ -> $add "<" ] ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
;
value rec antiquot_rest ctx bp =
lexer
[ "$"/
| "\\"/ (any ctx) (antiquot_rest ctx bp)!
| (any ctx) (antiquot_rest ctx bp)!
| -> err ctx (bp, $pos) "antiquotation not terminated" ]
;
value rec antiquot ctx bp =
lexer
[ "$"/ -> ":" ^ $buf
| [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot ctx bp)!
| ":" (antiquot_rest ctx bp)! -> $buf
| "\\"/ (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
| (any ctx) (antiquot_rest ctx bp)! -> ":" ^ $buf
| -> err ctx (bp, $pos) "antiquotation not terminated" ]
;
value antiloc bp ep s = Printf.sprintf "%d,%d:%s" bp ep s;
value rec antiquot_loc ctx bp =
lexer
[ "$"/ -> antiloc bp $pos (":" ^ $buf)
| [ 'a'-'z' | 'A'-'Z' | '0'-'9' | '!' | '_' ] (antiquot_loc ctx bp)!
| ":" (antiquot_rest ctx bp)! -> antiloc bp $pos $buf
| "\\"/ (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
| (any ctx) (antiquot_rest ctx bp)! -> antiloc bp $pos (":" ^ $buf)
| -> err ctx (bp, $pos) "antiquotation not terminated" ]
;
value dollar ctx bp buf strm =
if not no_quotations.val && ctx.dollar_for_antiquotation then
("ANTIQUOT", antiquot ctx bp buf strm)
else if force_antiquot_loc.val then
("ANTIQUOT_LOC", antiquot_loc ctx bp buf strm)
else
match strm with lexer
[ [ -> $add "$" ] ident2! -> ("", $buf) ]
;
(* ANTIQUOT - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
input expr patt
----- ---- ----
?$abc:d$ ?abc:d ?abc
?$abc:d$: ?abc:d: ?abc:
?$d$ ?:d ?
?$d$: ?:d: ?:
*)
(* ANTIQUOT_LOC - specific case for QUESTIONIDENT and QUESTIONIDENTCOLON
input expr patt
----- ---- ----
?$abc:d$ ?8,13:abc:d ?abc
?$abc:d$: ?8,13:abc:d: ?abc:
?$d$ ?8,9::d ?
?$d$: ?8,9::d: ?:
*)
value question ctx bp buf strm =
if ctx.dollar_for_antiquotation then
match strm with parser
[ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
("ANTIQUOT", "?" ^ s ^ ":")
| [: `'$'; s = antiquot ctx bp $empty :] ->
("ANTIQUOT", "?" ^ s)
| [: :] ->
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
else if force_antiquot_loc.val then
match strm with parser
[ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
("ANTIQUOT_LOC", "?" ^ s ^ ":")
| [: `'$'; s = antiquot_loc ctx bp $empty :] ->
("ANTIQUOT_LOC", "?" ^ s)
| [: :] ->
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
else
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
;
value tilde ctx bp buf strm =
if ctx.dollar_for_antiquotation then
match strm with parser
[ [: `'$'; s = antiquot ctx bp $empty; `':' :] ->
("ANTIQUOT", "~" ^ s ^ ":")
| [: `'$'; s = antiquot ctx bp $empty :] ->
("ANTIQUOT", "~" ^ s)
| [: :] ->
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
else if force_antiquot_loc.val then
match strm with parser
[ [: `'$'; s = antiquot_loc ctx bp $empty; `':' :] ->
("ANTIQUOT_LOC", "~" ^ s ^ ":")
| [: `'$'; s = antiquot_loc ctx bp $empty :] ->
("ANTIQUOT_LOC", "~" ^ s)
| [: :] ->
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ] ]
else
match strm with lexer
[ ident2! -> keyword_or_error ctx (bp, $pos) $buf ]
;
value tildeident =
lexer
[ ":"/ -> ("TILDEIDENTCOLON", $buf)
| -> ("TILDEIDENT", $buf) ]
;
value questionident =
lexer
[ ":"/ -> ("QUESTIONIDENTCOLON", $buf)
| -> ("QUESTIONIDENT", $buf) ]
;
value rec linedir n s =
match stream_peek_nth n s with
[ Some (' ' | '\t') -> linedir (n + 1) s
| Some ('0'..'9') -> linedir_digits (n + 1) s
| _ -> False ]
and linedir_digits n s =
match stream_peek_nth n s with
[ Some ('0'..'9') -> linedir_digits (n + 1) s
| _ -> linedir_quote n s ]
and linedir_quote n s =
match stream_peek_nth n s with
[ Some (' ' | '\t') -> linedir_quote (n + 1) s
| Some '"' -> True
| _ -> False ]
;
value rec any_to_nl =
lexer
[ "\r" | "\n"
| _ any_to_nl!
| ]
;
value next_token_after_spaces ctx bp =
lexer
[ 'A'-'Z' ident! ->
let id = $buf in
jrh_identifier ctx.find_kwd id
(********** JRH: original was
try ("", ctx.find_kwd id) with [ Not_found -> ("UIDENT", id) ]
*********)
| [ 'a'-'z' | '_' | misc_letter ] ident! ->
let id = $buf in
jrh_identifier ctx.find_kwd id
(********** JRH: original was
try ("", ctx.find_kwd id) with [ Not_found -> ("LIDENT", id) ]
*********)
| '1'-'9' number!
| "0" [ 'o' | 'O' ] (digits octal)!
| "0" [ 'x' | 'X' ] (digits hexa)!
| "0" [ 'b' | 'B' ] (digits binary)!
| "0" number!
| "'"/ ?= [ '\\' 'a'-'z' 'a'-'z' ] -> keyword_or_error ctx (bp, $pos) "'"
| "'"/ (char ctx bp) -> ("CHAR", $buf)
| "'" -> keyword_or_error ctx (bp, $pos) "'"
| "\""/ (string ctx bp)! -> ("STRING", $buf)
(*** Line added by JRH ***)
| "`"/ (qstring ctx bp)! -> ("QUOTATION", "tot:" ^ $buf)
| "$"/ (dollar ctx bp)!
| [ '!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' ] ident2! ->
keyword_or_error ctx (bp, $pos) $buf
| "~"/ 'a'-'z' ident! tildeident!
| "~"/ '_' ident! tildeident!
| "~" (tilde ctx bp)
| "?"/ 'a'-'z' ident! questionident!
| "?" (question ctx bp)!
| "<"/ (less ctx bp)!
| ":]" -> keyword_or_error ctx (bp, $pos) $buf
| "::" -> keyword_or_error ctx (bp, $pos) $buf
| ":=" -> keyword_or_error ctx (bp, $pos) $buf
| ":>" -> keyword_or_error ctx (bp, $pos) $buf
| ":" -> keyword_or_error ctx (bp, $pos) $buf
| ">]" -> keyword_or_error ctx (bp, $pos) $buf
| ">}" -> keyword_or_error ctx (bp, $pos) $buf
| ">" ident2! -> keyword_or_error ctx (bp, $pos) $buf
| "|]" -> keyword_or_error ctx (bp, $pos) $buf
| "|}" -> keyword_or_error ctx (bp, $pos) $buf
| "|" ident2! -> keyword_or_error ctx (bp, $pos) $buf
| "[" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
| "[|" -> keyword_or_error ctx (bp, $pos) $buf
| "[<" -> keyword_or_error ctx (bp, $pos) $buf
| "[:" -> keyword_or_error ctx (bp, $pos) $buf
| "[" -> keyword_or_error ctx (bp, $pos) $buf
| "{" ?= [ "<<" | "<:" ] -> keyword_or_error ctx (bp, $pos) $buf
| "{|" -> keyword_or_error ctx (bp, $pos) $buf
| "{<" -> keyword_or_error ctx (bp, $pos) $buf
| "{:" -> keyword_or_error ctx (bp, $pos) $buf
| "{" -> keyword_or_error ctx (bp, $pos) $buf
| ".." -> keyword_or_error ctx (bp, $pos) ".."
| "." ->
let id =
if ctx.specific_space_dot && ctx.after_space then " ." else "."
in
keyword_or_error ctx (bp, $pos) id
| ";;" -> keyword_or_error ctx (bp, $pos) ";;"
| ";" -> keyword_or_error ctx (bp, $pos) ";"
| misc_punct ident2! -> keyword_or_error ctx (bp, $pos) $buf
| "\\"/ ident3! -> ("LIDENT", $buf)
| (any ctx) -> keyword_or_error ctx (bp, $pos) $buf ]
;
value get_comment buf strm = $buf;
value rec next_token ctx buf =
parser bp
[ [: `('\n' | '\r' as c); s :] ep -> do {
if c = '\n' then incr Plexing.line_nb.val else ();
Plexing.bol_pos.val.val := ep;
ctx.set_line_nb ();
ctx.after_space := True;
next_token ctx ($add c) s
}
| [: `(' ' | '\t' | '\026' | '\012' as c); s :] -> do {
ctx.after_space := True;
next_token ctx ($add c) s
}
| [: `'#' when bp = Plexing.bol_pos.val.val; s :] ->
let comm = get_comment buf () in
if linedir 1 s then do {
let buf = any_to_nl ($add '#') s in
incr Plexing.line_nb.val;
Plexing.bol_pos.val.val := Stream.count s;
ctx.set_line_nb ();
ctx.after_space := True;
next_token ctx buf s
}
else
let loc = ctx.make_lined_loc (bp, bp + 1) comm in
(keyword_or_error ctx (bp, bp + 1) "#", loc)
| [: `'(';
a =
parser
[ [: `'*'; buf = comment ctx bp ($add "(*") !; s :] -> do {
ctx.set_line_nb ();
ctx.after_space := True;
next_token ctx buf s
}
| [: :] ep ->
let loc = ctx.make_lined_loc (bp, ep) $buf in
(keyword_or_error ctx (bp, ep) "(", loc) ] ! :] -> a
| [: comm = get_comment buf;
tok = next_token_after_spaces ctx bp $empty :] ep ->
let loc = ctx.make_lined_loc (bp, max (bp + 1) ep) comm in
(tok, loc)
| [: comm = get_comment buf; _ = Stream.empty :] ->
let loc = ctx.make_lined_loc (bp, bp + 1) comm in
(("EOI", ""), loc) ]
;
value next_token_fun ctx glexr (cstrm, s_line_nb, s_bol_pos) =
try do {
match Plexing.restore_lexing_info.val with
[ Some (line_nb, bol_pos) -> do {
s_line_nb.val := line_nb;
s_bol_pos.val := bol_pos;
Plexing.restore_lexing_info.val := None;
}
| None -> () ];
Plexing.line_nb.val := s_line_nb;
Plexing.bol_pos.val := s_bol_pos;
let comm_bp = Stream.count cstrm in
ctx.set_line_nb ();
ctx.after_space := False;
let (r, loc) = next_token ctx $empty cstrm in
match glexr.val.Plexing.tok_comm with
[ Some list ->
if Ploc.first_pos loc > comm_bp then
let comm_loc = Ploc.make_unlined (comm_bp, Ploc.last_pos loc) in
glexr.val.Plexing.tok_comm := Some [comm_loc :: list]
else ()
| None -> () ];
(r, loc)
}
with
[ Stream.Error str ->
err ctx (Stream.count cstrm, Stream.count cstrm + 1) str ]
;
value func kwd_table glexr =
let ctx =
let line_nb = ref 0 in
let bol_pos = ref 0 in
{after_space = False;
dollar_for_antiquotation = dollar_for_antiquotation.val;
specific_space_dot = specific_space_dot.val;
find_kwd = Hashtbl.find kwd_table;
line_cnt bp1 c =
match c with
[ '\n' | '\r' -> do {
if c = '\n' then incr Plexing.line_nb.val else ();
Plexing.bol_pos.val.val := bp1 + 1;
}
| c -> () ];
set_line_nb () = do {
line_nb.val := Plexing.line_nb.val.val;
bol_pos.val := Plexing.bol_pos.val.val;
};
make_lined_loc loc comm =
Ploc.make_loc Plexing.input_file.val line_nb.val bol_pos.val loc comm}
in
Plexing.lexer_func_of_parser (next_token_fun ctx glexr)
;
value rec check_keyword_stream =
parser [: _ = check $empty; _ = Stream.empty :] -> True
and check =
lexer
[ [ 'A'-'Z' | 'a'-'z' | misc_letter ] check_ident!
| [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
'.' ]
check_ident2!
| "$" check_ident2!
| "<" ?= [ ":" | "<" ]
| "<" check_ident2!
| ":]"
| "::"
| ":="
| ":>"
| ":"
| ">]"
| ">}"
| ">" check_ident2!
| "|]"
| "|}"
| "|" check_ident2!
| "[" ?= [ "<<" | "<:" ]
| "[|"
| "[<"
| "[:"
| "["
| "{" ?= [ "<<" | "<:" ]
| "{|"
| "{<"
| "{:"
| "{"
| ";;"
| ";"
| misc_punct check_ident2!
| _ ]
and check_ident =
lexer
[ [ 'A'-'Z' | 'a'-'z' | '0'-'9' | '_' | ''' | misc_letter ]
check_ident! | ]
and check_ident2 =
lexer
[ [ '!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
'.' | ':' | '<' | '>' | '|' | misc_punct ]
check_ident2! | ]
;
value check_keyword s =
try check_keyword_stream (Stream.of_string s) with _ -> False
;
value error_no_respect_rules p_con p_prm =
raise
(Plexing.Error
("the token " ^
(if p_con = "" then "\"" ^ p_prm ^ "\""
else if p_prm = "" then p_con
else p_con ^ " \"" ^ p_prm ^ "\"") ^
" does not respect Plexer rules"))
;
value error_ident_and_keyword p_con p_prm =
raise
(Plexing.Error
("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
" and as keyword"))
;
value using_token kwd_table ident_table (p_con, p_prm) =
match p_con with
[ "" ->
if not (hashtbl_mem kwd_table p_prm) then
if check_keyword p_prm then
if hashtbl_mem ident_table p_prm then
error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
else Hashtbl.add kwd_table p_prm p_prm
else error_no_respect_rules p_con p_prm
else ()
| "LIDENT" ->
if p_prm = "" then ()
else
match p_prm.[0] with
[ 'A'..'Z' -> error_no_respect_rules p_con p_prm
| _ ->
if hashtbl_mem kwd_table p_prm then
error_ident_and_keyword p_con p_prm
else Hashtbl.add ident_table p_prm p_con ]
| "UIDENT" ->
if p_prm = "" then ()
else
match p_prm.[0] with
[ 'a'..'z' -> error_no_respect_rules p_con p_prm
| _ ->
if hashtbl_mem kwd_table p_prm then
error_ident_and_keyword p_con p_prm
else Hashtbl.add ident_table p_prm p_con ]
| "TILDEIDENT" | "TILDEIDENTCOLON" | "QUESTIONIDENT" |
"QUESTIONIDENTCOLON" | "INT" | "INT_l" | "INT_L" | "INT_n" | "FLOAT" |
"CHAR" | "STRING" | "QUOTATION" |
"ANTIQUOT" | "ANTIQUOT_LOC" | "EOI" ->
()
| _ ->
raise
(Plexing.Error
("the constructor \"" ^ p_con ^
"\" is not recognized by Plexer")) ]
;
value removing_token kwd_table ident_table (p_con, p_prm) =
match p_con with
[ "" -> Hashtbl.remove kwd_table p_prm
| "LIDENT" | "UIDENT" ->
if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
| _ -> () ]
;
value text =
fun
[ ("", t) -> "'" ^ t ^ "'"
| ("LIDENT", "") -> "lowercase identifier"
| ("LIDENT", t) -> "'" ^ t ^ "'"
| ("UIDENT", "") -> "uppercase identifier"
| ("UIDENT", t) -> "'" ^ t ^ "'"
| ("INT", "") -> "integer"
| ("INT", s) -> "'" ^ s ^ "'"
| ("FLOAT", "") -> "float"
| ("STRING", "") -> "string"
| ("CHAR", "") -> "char"
| ("QUOTATION", "") -> "quotation"
| ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
| ("EOI", "") -> "end of input"
| (con, "") -> con
| (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
;
value eq_before_colon p e =
loop 0 where rec loop i =
if i == String.length e then
failwith "Internal error in Plexer: incorrect ANTIQUOT"
else if i == String.length p then e.[i] == ':'
else if p.[i] == e.[i] then loop (i + 1)
else False
;
value after_colon e =
try
let i = String.index e ':' in
String.sub e (i + 1) (String.length e - i - 1)
with
[ Not_found -> "" ]
;
value after_colon_except_last e =
try
let i = String.index e ':' in
String.sub e (i + 1) (String.length e - i - 2)
with
[ Not_found -> "" ]
;
value tok_match =
fun
[ ("ANTIQUOT", p_prm) ->
if p_prm <> "" && (p_prm.[0] = '~' || p_prm.[0] = '?') then
if p_prm.[String.length p_prm - 1] = ':' then
let p_prm = String.sub p_prm 0 (String.length p_prm - 1) in
fun
[ ("ANTIQUOT", prm) ->
if prm <> "" && prm.[String.length prm - 1] = ':' then
if eq_before_colon p_prm prm then after_colon_except_last prm
else raise Stream.Failure
else raise Stream.Failure
| _ -> raise Stream.Failure ]
else
fun
[ ("ANTIQUOT", prm) ->
if prm <> "" && prm.[String.length prm - 1] = ':' then
raise Stream.Failure
else if eq_before_colon p_prm prm then after_colon prm
else raise Stream.Failure
| _ -> raise Stream.Failure ]
else
fun
[ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
| _ -> raise Stream.Failure ]
| tok -> Plexing.default_match tok ]
;
value gmake () =
let kwd_table = Hashtbl.create 301 in
let id_table = Hashtbl.create 301 in
let glexr =
ref
{Plexing.tok_func = fun []; tok_using = fun []; tok_removing = fun [];
tok_match = fun []; tok_text = fun []; tok_comm = None}
in
let glex =
{Plexing.tok_func = func kwd_table glexr;
tok_using = using_token kwd_table id_table;
tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
tok_text = text; tok_comm = None}
in
do { glexr.val := glex; glex }
;
(* ------------------------------------------------------------------------- *)
(* Back to etc/pa_o.ml *)
(* ------------------------------------------------------------------------- *)
do {
let odfa = dollar_for_antiquotation.val in
dollar_for_antiquotation.val := False;
Grammar.Unsafe.gram_reinit gram (gmake ());
dollar_for_antiquotation.val := odfa;
Grammar.Unsafe.clear_entry interf;
Grammar.Unsafe.clear_entry implem;
Grammar.Unsafe.clear_entry top_phrase;
Grammar.Unsafe.clear_entry use_file;
Grammar.Unsafe.clear_entry module_type;
Grammar.Unsafe.clear_entry module_expr;
Grammar.Unsafe.clear_entry sig_item;
Grammar.Unsafe.clear_entry str_item;
Grammar.Unsafe.clear_entry signature;
Grammar.Unsafe.clear_entry structure;
Grammar.Unsafe.clear_entry expr;
Grammar.Unsafe.clear_entry patt;
Grammar.Unsafe.clear_entry ctyp;
Grammar.Unsafe.clear_entry let_binding;
Grammar.Unsafe.clear_entry type_decl;
Grammar.Unsafe.clear_entry constructor_declaration;
Grammar.Unsafe.clear_entry label_declaration;
Grammar.Unsafe.clear_entry match_case;
Grammar.Unsafe.clear_entry with_constr;
Grammar.Unsafe.clear_entry poly_variant;
Grammar.Unsafe.clear_entry class_type;
Grammar.Unsafe.clear_entry class_expr;
Grammar.Unsafe.clear_entry class_sig_item;
Grammar.Unsafe.clear_entry class_str_item
};
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
value mklistexp loc last =
loop True where rec loop top =
fun
[ [] ->
match last with
[ Some e -> e
| None -> <:expr< [] >> ]
| [e1 :: el] ->
let loc =
if top then loc else Ploc.encl (MLast.loc_of_expr e1) loc
in
<:expr< [$e1$ :: $loop False el$] >> ]
;
value mklistpat loc last =
loop True where rec loop top =
fun
[ [] ->
match last with
[ Some p -> p
| None -> <:patt< [] >> ]
| [p1 :: pl] ->
let loc =
if top then loc else Ploc.encl (MLast.loc_of_patt p1) loc
in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
(*** JRH pulled this outside so user can add new infixes here too ***)
value ht = Hashtbl.create 73;
(*** And JRH added all the new HOL Light infixes here already ***)
value is_operator = do {
let ct = Hashtbl.create 73 in
List.iter (fun x -> Hashtbl.add ht x True)
["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
"F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
"THEN_TCL"; "ORELSE_TCL"];
List.iter (fun x -> Hashtbl.add ct x True)
['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
'?'; '%'; '.'; '$'];
fun x ->
try Hashtbl.find ht x with
[ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
};
(*** JRH added this so parenthesised operators undergo same mapping ***)
value translate_operator =
fun s ->
match s with
[ "THEN" -> "then_"
| "THENC" -> "thenc_"
| "THENL" -> "thenl_"
| "ORELSE" -> "orelse_"
| "ORELSEC" -> "orelsec_"
| "THEN_TCL" -> "then_tcl_"
| "ORELSE_TCL" -> "orelse_tcl_"
| "F_F" -> "f_f_"
| _ -> s];
value operator_rparen =
Grammar.Entry.of_parser gram "operator_rparen"
(fun strm ->
match Stream.npeek 2 strm with
[ [("", s); ("", ")")] when is_operator s -> do {
Stream.junk strm;
Stream.junk strm;
translate_operator s
}
| _ -> raise Stream.Failure ])
;
value check_not_part_of_patt =
Grammar.Entry.of_parser gram "check_not_part_of_patt"
(fun strm ->
let tok =
match Stream.npeek 4 strm with
[ [("LIDENT", _); tok :: _] -> tok
| [("", "("); ("", s); ("", ")"); tok] when is_operator s -> tok
| _ -> raise Stream.Failure ]
in
match tok with
[ ("", "," | "as" | "|" | "::") -> raise Stream.Failure
| _ -> () ])
;
value symbolchar =
let list =
['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
'@'; '^'; '|'; '~']
in
loop where rec loop s i =
if i == String.length s then True
else if List.mem s.[i] list then loop s (i + 1)
else False
;
value prefixop =
let list = ['!'; '?'; '~'] in
let excl = ["!="; "??"; "?!"] in
Grammar.Entry.of_parser gram "prefixop"
(parser
[: `("", x)
when
not (List.mem x excl) && String.length x >= 2 &&
List.mem x.[0] list && symbolchar x 1 :] ->
x)
;
value infixop0 =
let list = ['='; '<'; '>'; '|'; '&'; '$'] in
let excl = ["<-"; "||"; "&&"] in
Grammar.Entry.of_parser gram "infixop0"
(parser
[: `("", x)
when
not (List.mem x excl) && (x = "$" || String.length x >= 2) &&
List.mem x.[0] list && symbolchar x 1 :] ->
x)
;
value infixop1 =
let list = ['@'; '^'] in
Grammar.Entry.of_parser gram "infixop1"
(parser
[: `("", x)
when
String.length x >= 2 && List.mem x.[0] list &&
symbolchar x 1 :] ->
x)
;
value infixop2 =
let list = ['+'; '-'] in
Grammar.Entry.of_parser gram "infixop2"
(parser
[: `("", x)
when
x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
symbolchar x 1 :] ->
x)
;
value infixop3 =
let list = ['*'; '/'; '%'] in
Grammar.Entry.of_parser gram "infixop3"
(parser
[: `("", x)
when
String.length x >= 2 && List.mem x.[0] list &&
symbolchar x 1 :] ->
x)
;
value infixop4 =
Grammar.Entry.of_parser gram "infixop4"
(parser
[: `("", x)
when
String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
symbolchar x 2 :] ->
x)
;
value test_constr_decl =
Grammar.Entry.of_parser gram "test_constr_decl"
(fun strm ->
match Stream.npeek 1 strm with
[ [("UIDENT", _)] ->
match Stream.npeek 2 strm with
[ [_; ("", ".")] -> raise Stream.Failure
| [_; ("", "(")] -> raise Stream.Failure
| [_ :: _] -> ()
| _ -> raise Stream.Failure ]
| [("", "|")] -> ()
| _ -> raise Stream.Failure ])
;
value stream_peek_nth n strm =
loop n (Stream.npeek n strm) where rec loop n =
fun
[ [] -> None
| [x] -> if n == 1 then Some x else None
| [_ :: l] -> loop (n - 1) l ]
;
(* horrible hack to be able to parse class_types *)
value test_ctyp_minusgreater =
Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
(fun strm ->
let rec skip_simple_ctyp n =
match stream_peek_nth n strm with
[ Some ("", "->") -> n
| Some ("", "[" | "[<") ->
skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
| Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
| Some
("",
"as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
"_") ->
skip_simple_ctyp (n + 1)
| Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
skip_simple_ctyp (n + 1)
| Some _ | None -> raise Stream.Failure ]
and ignore_upto end_kwd n =
match stream_peek_nth n strm with
[ Some ("", prm) when prm = end_kwd -> n
| Some ("", "[" | "[<") ->
ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
| Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
| Some _ -> ignore_upto end_kwd (n + 1)
| None -> raise Stream.Failure ]
in
match Stream.peek strm with
[ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
| Some ("", "object") -> raise Stream.Failure
| _ -> 1 ])
;
value test_label_eq =
Grammar.Entry.of_parser gram "test_label_eq"
(test 1 where rec test lev strm =
match stream_peek_nth lev strm with
[ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
test (lev + 1) strm
| Some ("ANTIQUOT_LOC", _) -> ()
| Some ("", "=") -> ()
| _ -> raise Stream.Failure ])
;
value test_typevar_list_dot =
Grammar.Entry.of_parser gram "test_typevar_list_dot"
(let rec test lev strm =
match stream_peek_nth lev strm with
[ Some ("", "'") -> test2 (lev + 1) strm
| Some ("", ".") -> ()
| _ -> raise Stream.Failure ]
and test2 lev strm =
match stream_peek_nth lev strm with
[ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
| _ -> raise Stream.Failure ]
in
test 1)
;
value e_phony =
Grammar.Entry.of_parser gram "e_phony"
(parser [])
;
value p_phony =
Grammar.Entry.of_parser gram "p_phony"
(parser [])
;
value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
value rec is_expr_constr_call =
fun
[ <:expr< $uid:_$ >> -> True
| <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
| <:expr< $e$ $_$ >> -> is_expr_constr_call e
| _ -> False ]
;
value rec constr_expr_arity loc =
fun
[ <:expr< $uid:c$ >> ->
try List.assoc c constr_arity.val with [ Not_found -> 0 ]
| <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
| _ -> 1 ]
;
value rec constr_patt_arity loc =
fun
[ <:patt< $uid:c$ >> ->
try List.assoc c constr_arity.val with [ Not_found -> 0 ]
| <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
| _ -> 1 ]
;
value get_seq =
fun
[ <:expr< do { $list:el$ } >> -> el
| e -> [e] ]
;
value mem_tvar s tpl =
List.exists (fun (t, _) -> Pcaml.unvala t = Some s) tpl
;
value choose_tvar tpl =
let rec find_alpha v =
let s = String.make 1 v in
if mem_tvar s tpl then
if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
else Some (String.make 1 v)
in
let rec make_n n =
let v = "a" ^ string_of_int n in
if mem_tvar v tpl then make_n (succ n) else v
in
match find_alpha 'a' with
[ Some x -> x
| None -> make_n 1 ]
;
value quotation_content s = do {
loop 0 where rec loop i =
if i = String.length s then ("", s)
else if s.[i] = ':' || s.[i] = '@' then
let i = i + 1 in
(String.sub s 0 i, String.sub s i (String.length s - i))
else loop (i + 1)
};
value concat_comm loc e =
let loc =
Ploc.with_comment loc
(Ploc.comment loc ^ Ploc.comment (MLast.loc_of_expr e))
in
let floc =
let first = ref True in
fun loc1 ->
if first.val then do {first.val := False; loc}
else loc1
in
reloc_expr floc 0 e
;
EXTEND
GLOBAL: sig_item str_item ctyp patt expr module_type module_expr
signature structure class_type class_expr class_sig_item class_str_item
let_binding type_decl constructor_declaration label_declaration
match_case with_constr poly_variant;
module_expr:
[ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = module_type; ")";
"->"; me = SELF ->
<:module_expr< functor ( $_uid:i$ : $t$ ) -> $me$ >>
| "struct"; st = structure; "end" ->
<:module_expr< struct $_list:st$ end >> ]
| [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ]
| [ me1 = SELF; "("; me2 = SELF; ")" -> <:module_expr< $me1$ $me2$ >> ]
| [ i = mod_expr_ident -> i
| "("; "val"; e = expr; ":"; mt = module_type; ")" ->
<:module_expr< (value $e$ : $mt$) >>
| "("; "val"; e = expr; ")" ->
<:module_expr< (value $e$) >>
| "("; me = SELF; ":"; mt = module_type; ")" ->
<:module_expr< ( $me$ : $mt$ ) >>
| "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
;
structure:
[ [ st = V (LIST0 [ s = str_item; OPT ";;" -> s ]) -> st ] ]
;
mod_expr_ident:
[ LEFTA
[ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
| [ i = V UIDENT -> <:module_expr< $_uid:i$ >> ] ]
;
str_item:
[ "top"
[ "exception"; (_, c, tl, _) = constructor_declaration;
b = rebind_exn ->
<:str_item< exception $_uid:c$ of $_list:tl$ = $_list:b$ >>
| "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
pd = V (LIST1 STRING) ->
<:str_item< external $_lid:i$ : $t$ = $_list:pd$ >>
| "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
pd = V (LIST1 STRING) ->
<:str_item< external $lid:i$ : $t$ = $_list:pd$ >>
| "include"; me = module_expr -> <:str_item< include $me$ >>
| "module"; r = V (FLAG "rec"); l = V (LIST1 mod_binding SEP "and") ->
<:str_item< module $_flag:r$ $_list:l$ >>
| "module"; "type"; i = V UIDENT "uid" ""; "="; mt = module_type ->
<:str_item< module type $_uid:i$ = $mt$ >>
| "open"; i = V mod_ident "list" "" ->
<:str_item< open $_:i$ >>
| "type"; tdl = V (LIST1 type_decl SEP "and") ->
<:str_item< type $_list:tdl$ >>
| "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
x = expr ->
let e = <:expr< let $_flag:r$ $_list:l$ in $x$ >> in
<:str_item< $exp:e$ >>
| "let"; r = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and") ->
match l with
[ <:vala< [(p, e)] >> ->
match p with
[ <:patt< _ >> -> <:str_item< $exp:e$ >>
| _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
| _ -> <:str_item< value $_flag:r$ $_list:l$ >> ]
| "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in"; e = expr ->
<:str_item< let module $_uid:m$ = $mb$ in $e$ >>
| e = expr -> <:str_item< $exp:e$ >> ] ]
;
rebind_exn:
[ [ "="; sl = V mod_ident "list" -> sl
| -> <:vala< [] >> ] ]
;
mod_binding:
[ [ i = V UIDENT; me = mod_fun_binding -> (i, me) ] ]
;
mod_fun_binding:
[ RIGHTA
[ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
<:module_expr< functor ( $uid:m$ : $mt$ ) -> $mb$ >>
| ":"; mt = module_type; "="; me = module_expr ->
<:module_expr< ( $me$ : $mt$ ) >>
| "="; me = module_expr -> <:module_expr< $me$ >> ] ]
;
(* Module types *)
module_type:
[ [ "functor"; "("; i = V UIDENT "uid" ""; ":"; t = SELF; ")"; "->";
mt = SELF ->
<:module_type< functor ( $_uid:i$ : $t$ ) -> $mt$ >> ]
| [ mt = SELF; "with"; wcl = V (LIST1 with_constr SEP "and") ->
<:module_type< $mt$ with $_list:wcl$ >> ]
| [ "sig"; sg = signature; "end" ->
<:module_type< sig $_list:sg$ end >>
| "module"; "type"; "of"; me = module_expr ->
<:module_type< module type of $me$ >>
| i = mod_type_ident -> i
| "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
;
signature:
[ [ sg = V (LIST0 [ s = sig_item; OPT ";;" -> s ]) -> sg ] ]
;
mod_type_ident:
[ LEFTA
[ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
| m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
| [ m = V UIDENT -> <:module_type< $_uid:m$ >>
| m = V LIDENT -> <:module_type< $_lid:m$ >> ] ]
;
sig_item:
[ "top"
[ "exception"; (_, c, tl, _) = constructor_declaration ->
<:sig_item< exception $_uid:c$ of $_list:tl$ >>
| "external"; i = V LIDENT "lid" ""; ":"; t = ctyp; "=";
pd = V (LIST1 STRING) ->
<:sig_item< external $_lid:i$ : $t$ = $_list:pd$ >>
| "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
pd = V (LIST1 STRING) ->
<:sig_item< external $lid:i$ : $t$ = $_list:pd$ >>
| "include"; mt = module_type ->
<:sig_item< include $mt$ >>
| "module"; rf = V (FLAG "rec");
l = V (LIST1 mod_decl_binding SEP "and") ->
<:sig_item< module $_flag:rf$ $_list:l$ >>
| "module"; "type"; i = V UIDENT "uid" ""; "="; mt = module_type ->
<:sig_item< module type $_uid:i$ = $mt$ >>
| "module"; "type"; i = V UIDENT "uid" "" ->
<:sig_item< module type $_uid:i$ = 'abstract >>
| "open"; i = V mod_ident "list" "" ->
<:sig_item< open $_:i$ >>
| "type"; tdl = V (LIST1 type_decl SEP "and") ->
<:sig_item< type $_list:tdl$ >>
| "val"; i = V LIDENT "lid" ""; ":"; t = ctyp ->
<:sig_item< value $_lid:i$ : $t$ >>
| "val"; "("; i = operator_rparen; ":"; t = ctyp ->
<:sig_item< value $lid:i$ : $t$ >> ] ]
;
mod_decl_binding:
[ [ i = V UIDENT; mt = module_declaration -> (i, mt) ] ]
;
module_declaration:
[ RIGHTA
[ ":"; mt = module_type -> <:module_type< $mt$ >>
| "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
<:module_type< functor ( $uid:i$ : $t$ ) -> $mt$ >> ] ]
;
(* "with" constraints (additional type equations over signature
components) *)
with_constr:
[ [ "type"; tpl = V type_parameters "list"; i = V mod_ident ""; "=";
pf = V (FLAG "private"); t = ctyp ->
<:with_constr< type $_:i$ $_list:tpl$ = $_flag:pf$ $t$ >>
| "type"; tpl = V type_parameters "list"; i = V mod_ident ""; ":=";
t = ctyp ->
<:with_constr< type $_:i$ $_list:tpl$ := $t$ >>
| "module"; i = V mod_ident ""; "="; me = module_expr ->
<:with_constr< module $_:i$ = $me$ >>
| "module"; i = V mod_ident ""; ":="; me = module_expr ->
<:with_constr< module $_:i$ := $me$ >> ] ]
;
(* Core expressions *)
expr:
[ "top" RIGHTA
[ e1 = SELF; ";"; e2 = SELF ->
<:expr< do { $list:[e1 :: get_seq e2]$ } >>
| e1 = SELF; ";" -> e1
| el = V e_phony "list" -> <:expr< do { $_list:el$ } >> ]
| "expr1"
[ "let"; o = V (FLAG "rec"); l = V (LIST1 let_binding SEP "and"); "in";
x = expr LEVEL "top" ->
<:expr< let $_flag:o$ $_list:l$ in $x$ >>
| "let"; "module"; m = V UIDENT; mb = mod_fun_binding; "in";
e = expr LEVEL "top" ->
<:expr< let module $_uid:m$ = $mb$ in $e$ >>
| "function"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
<:expr< fun [ $_list:l$ ] >>
| "fun"; p = patt LEVEL "simple"; (eo, e) = fun_def ->
<:expr< fun [$p$ $opt:eo$ -> $e$] >>
| "match"; e = SELF; "with"; OPT "|";
l = V (LIST1 match_case SEP "|") ->
<:expr< match $e$ with [ $_list:l$ ] >>
| "try"; e = SELF; "with"; OPT "|"; l = V (LIST1 match_case SEP "|") ->
<:expr< try $e$ with [ $_list:l$ ] >>
| "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; "else";
e3 = expr LEVEL "expr1" ->
<:expr< if $e1$ then $e2$ else $e3$ >>
| "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
<:expr< if $e1$ then $e2$ else () >>
| "for"; i = V LIDENT; "="; e1 = SELF; df = V direction_flag "to";
e2 = SELF; "do"; e = V SELF "list"; "done" ->
let el = Pcaml.vala_map get_seq e in
<:expr< for $_lid:i$ = $e1$ $_to:df$ $e2$ do { $_list:el$ } >>
| "while"; e1 = SELF; "do"; e2 = V SELF "list"; "done" ->
let el = Pcaml.vala_map get_seq e2 in
<:expr< while $e1$ do { $_list:el$ } >> ]
| [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
<:expr< ( $list:[e :: el]$ ) >> ]
| ":=" NONA
[ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
<:expr< $e1$.val := $e2$ >>
| e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
| "||" RIGHTA
[ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
| e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
| "&&" RIGHTA
[ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
| e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
| "<" LEFTA
[ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
| e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
| e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
| e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
| e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
| e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
| e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
| e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
| e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| "^" RIGHTA
[ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
| e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
| e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| RIGHTA
[ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
| "+" LEFTA
[ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
| e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
| e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| "*" LEFTA
[ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
| e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
| e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
| e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
| e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
| e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
| e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
| e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| "**" RIGHTA
[ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
| e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
| e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
| e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
| e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| "unary minus" NONA
[ "-"; e = SELF -> <:expr< - $e$ >>
| "-."; e = SELF -> <:expr< -. $e$ >> ]
| "apply" LEFTA
[ e1 = SELF; e2 = SELF ->
let (e1, e2) =
if is_expr_constr_call e1 then
match e1 with
[ <:expr< $e11$ $e12$ >> -> (e11, <:expr< $e12$ $e2$ >>)
| _ -> (e1, e2) ]
else (e1, e2)
in
match constr_expr_arity loc e1 with
[ 1 -> <:expr< $e1$ $e2$ >>
| _ ->
match e2 with
[ <:expr< ( $list:el$ ) >> ->
List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
| _ -> <:expr< $e1$ $e2$ >> ] ]
| "assert"; e = SELF -> <:expr< assert $e$ >>
| "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
| "." LEFTA
[ e1 = SELF; "."; "("; op = operator_rparen ->
<:expr< $e1$ .( $lid:op$ ) >>
| e1 = SELF; "."; "("; e2 = SELF; ")" ->
<:expr< $e1$ .( $e2$ ) >>
| e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
| e = SELF; "."; "{"; el = V (LIST1 expr LEVEL "+" SEP ","); "}" ->
<:expr< $e$ .{ $_list:el$ } >>
| e1 = SELF; "."; e2 = SELF ->
let rec loop m =
fun
[ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
| e -> <:expr< $m$ . $e$ >> ]
in
loop e1 e2 ]
| "~-" NONA
[ "!"; e = SELF -> <:expr< $e$ . val >>
| "~-"; e = SELF -> <:expr< ~- $e$ >>
| "~-."; e = SELF -> <:expr< ~-. $e$ >>
| f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
| "simple" LEFTA
[ s = V INT -> <:expr< $_int:s$ >>
| s = V INT_l -> <:expr< $_int32:s$ >>
| s = V INT_L -> <:expr< $_int64:s$ >>
| s = V INT_n -> <:expr< $_nativeint:s$ >>
| s = V FLOAT -> <:expr< $_flo:s$ >>
| s = V STRING -> <:expr< $_str:s$ >>
| c = V CHAR -> <:expr< $_chr:c$ >>
| UIDENT "True" -> <:expr< True_ >>
| UIDENT "False" -> <:expr< False_ >>
| i = expr_ident -> i
| "false" -> <:expr< False >>
| "true" -> <:expr< True >>
| "["; "]" -> <:expr< [] >>
| "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
| "[|"; "|]" -> <:expr< [| |] >>
| "[|"; el = V expr1_semi_list "list"; "|]" ->
<:expr< [| $_list:el$ |] >>
| "{"; test_label_eq; lel = V lbl_expr_list "list"; "}" ->
<:expr< { $_list:lel$ } >>
| "{"; e = expr LEVEL "."; "with"; lel = V lbl_expr_list "list"; "}" ->
<:expr< { ($e$) with $_list:lel$ } >>
| "("; ")" -> <:expr< () >>
| "("; "module"; me = module_expr; ":"; mt = module_type; ")" ->
<:expr< (module $me$ : $mt$) >>
| "("; "module"; me = module_expr; ")" ->
<:expr< (module $me$) >>
| "("; op = operator_rparen -> <:expr< $lid:op$ >>
| "("; el = V e_phony "list"; ")" -> <:expr< ($_list:el$) >>
| "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
| "("; e = SELF; ")" -> concat_comm loc <:expr< $e$ >>
| "begin"; e = SELF; "end" -> concat_comm loc <:expr< $e$ >>
| "begin"; "end" -> <:expr< () >>
| x = QUOTATION ->
let con = quotation_content x in
Pcaml.handle_expr_quotation loc con ] ]
;
let_binding:
[ [ p = val_ident; e = fun_binding -> (p, e)
| p = patt; "="; e = expr -> (p, e)
| p = patt; ":"; t = poly_type; "="; e = expr ->
(<:patt< ($p$ : $t$) >>, e) ] ]
;
(*** JRH added the "translate_operator" here ***)
val_ident:
[ [ check_not_part_of_patt; s = LIDENT -> <:patt< $lid:s$ >>
| check_not_part_of_patt; "("; s = ANY; ")" ->
let s' = translate_operator s in <:patt< $lid:s'$ >> ] ]
;
fun_binding:
[ RIGHTA
[ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
| "="; e = expr -> <:expr< $e$ >>
| ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
;
match_case:
[ [ x1 = patt; w = V (OPT [ "when"; e = expr -> e ]); "->"; x2 = expr ->
(x1, w, x2) ] ]
;
lbl_expr_list:
[ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
| le = lbl_expr; ";" -> [le]
| le = lbl_expr -> [le] ] ]
;
lbl_expr:
[ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
;
expr1_semi_list:
[ [ el = LIST1 (expr LEVEL "expr1") SEP ";" OPT_SEP -> el ] ]
;
fun_def:
[ RIGHTA
[ p = patt LEVEL "simple"; (eo, e) = SELF ->
(None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>)
| eo = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
(eo, <:expr< $e$ >>) ] ]
;
expr_ident:
[ RIGHTA
[ i = V LIDENT -> <:expr< $_lid:i$ >>
| i = V UIDENT -> <:expr< $_uid:i$ >>
| i = V UIDENT; "."; j = SELF ->
let rec loop m =
fun
[ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
| e -> <:expr< $m$ . $e$ >> ]
in
loop <:expr< $_uid:i$ >> j
| i = V UIDENT; "."; "("; j = operator_rparen ->
<:expr< $_uid:i$ . $lid:j$ >> ] ]
;
(* Patterns *)
patt:
[ LEFTA
[ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
| LEFTA
[ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
| [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
<:patt< ( $list:[p :: pl]$) >> ]
| NONA
[ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
| RIGHTA
[ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
| LEFTA
[ p1 = SELF; p2 = SELF ->
let (p1, p2) =
match p1 with
[ <:patt< $p11$ $p12$ >> -> (p11, <:patt< $p12$ $p2$ >>)
| _ -> (p1, p2) ]
in
match constr_patt_arity loc p1 with
[ 1 -> <:patt< $p1$ $p2$ >>
| n ->
let p2 =
match p2 with
[ <:patt< _ >> when n > 1 ->
let pl =
loop n where rec loop n =
if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
in
<:patt< ( $list:pl$ ) >>
| _ -> p2 ]
in
match p2 with
[ <:patt< ( $list:pl$ ) >> ->
List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
| _ -> <:patt< $p1$ $p2$ >> ] ]
| "lazy"; p = SELF -> <:patt< lazy $p$ >> ]
| LEFTA
[ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
| "simple"
[ s = V LIDENT -> <:patt< $_lid:s$ >>
| s = V UIDENT -> <:patt< $_uid:s$ >>
| s = V INT -> <:patt< $_int:s$ >>
| s = V INT_l -> <:patt< $_int32:s$ >>
| s = V INT_L -> <:patt< $_int64:s$ >>
| s = V INT_n -> <:patt< $_nativeint:s$ >>
| "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
| "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
| s = V FLOAT -> <:patt< $_flo:s$ >>
| s = V STRING -> <:patt< $_str:s$ >>
| s = V CHAR -> <:patt< $_chr:s$ >>
| UIDENT "True" -> <:patt< True_ >>
| UIDENT "False" -> <:patt< False_ >>
| "false" -> <:patt< False >>
| "true" -> <:patt< True >>
| "["; "]" -> <:patt< [] >>
| "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
| "[|"; "|]" -> <:patt< [| |] >>
| "[|"; pl = V patt_semi_list "list"; "|]" ->
<:patt< [| $_list:pl$ |] >>
| "{"; lpl = V lbl_patt_list "list"; "}" ->
<:patt< { $_list:lpl$ } >>
| "("; ")" -> <:patt< () >>
| "("; op = operator_rparen -> <:patt< $lid:op$ >>
| "("; pl = V p_phony "list"; ")" -> <:patt< ($_list:pl$) >>
| "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
| "("; p = SELF; ")" -> <:patt< $p$ >>
| "("; "type"; s = V LIDENT; ")" -> <:patt< (type $_lid:s$) >>
| "("; "module"; s = V UIDENT; ":"; mt = module_type; ")" ->
<:patt< (module $_uid:s$ : $mt$) >>
| "("; "module"; s = V UIDENT; ")" ->
<:patt< (module $_uid:s$) >>
| "_" -> <:patt< _ >>
| x = QUOTATION ->
let con = quotation_content x in
Pcaml.handle_patt_quotation loc con ] ]
;
patt_semi_list:
[ [ p = patt; ";"; pl = SELF -> [p :: pl]
| p = patt; ";" -> [p]
| p = patt -> [p] ] ]
;
lbl_patt_list:
[ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
| le = lbl_patt; ";" -> [le]
| le = lbl_patt -> [le] ] ]
;
lbl_patt:
[ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
;
patt_label_ident:
[ LEFTA
[ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
| RIGHTA
[ i = UIDENT -> <:patt< $uid:i$ >>
| i = LIDENT -> <:patt< $lid:i$ >> ] ]
;
(* Type declaration *)
type_decl:
[ [ tpl = type_parameters; n = V type_patt; "="; pf = V (FLAG "private");
tk = type_kind; cl = V (LIST0 constrain) ->
<:type_decl< $_tp:n$ $list:tpl$ = $_priv:pf$ $tk$ $_list:cl$ >>
| tpl = type_parameters; n = V type_patt; cl = V (LIST0 constrain) ->
let tk = <:ctyp< '$choose_tvar tpl$ >> in
<:type_decl< $_tp:n$ $list:tpl$ = $tk$ $_list:cl$ >> ] ]
;
type_patt:
[ [ n = V LIDENT -> (loc, n) ] ]
;
constrain:
[ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
;
type_kind:
[ [ test_constr_decl; OPT "|";
cdl = LIST1 constructor_declaration SEP "|" ->
<:ctyp< [ $list:cdl$ ] >>
| t = ctyp ->
<:ctyp< $t$ >>
| t = ctyp; "="; pf = FLAG "private"; "{";
ldl = V label_declarations "list"; "}" ->
<:ctyp< $t$ == $priv:pf$ { $_list:ldl$ } >>
| t = ctyp; "="; pf = FLAG "private"; OPT "|";
cdl = LIST1 constructor_declaration SEP "|" ->
<:ctyp< $t$ == $priv:pf$ [ $list:cdl$ ] >>
| "{"; ldl = V label_declarations "list"; "}" ->
<:ctyp< { $_list:ldl$ } >> ] ]
;
type_parameters:
[ [ -> (* empty *) []
| tp = type_parameter -> [tp]
| "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
;
type_parameter:
[ [ "+"; p = V simple_type_parameter -> (p, Some True)
| "-"; p = V simple_type_parameter -> (p, Some False)
| p = V simple_type_parameter -> (p, None) ] ]
;
simple_type_parameter:
[ [ "'"; i = ident -> Some i
| "_" -> None ] ]
;
constructor_declaration:
[ [ ci = cons_ident; "of"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
(loc, ci, cal, None)
| ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*");
"->"; t = ctyp ->
(loc, ci, cal, Some t)
| ci = cons_ident; ":"; cal = V (LIST1 (ctyp LEVEL "apply") SEP "*") ->
let t =
match cal with
[ <:vala< [t] >> -> t
| <:vala< [t :: tl] >> -> <:ctyp< ($list:[t :: tl]$) >>
| _ -> assert False ]
in
(loc, ci, <:vala< [] >>, Some t)
| ci = cons_ident -> (loc, ci, <:vala< [] >>, None) ] ]
;
cons_ident:
[ [ i = V UIDENT "uid" "" -> i
| UIDENT "True" -> <:vala< "True_" >>
| UIDENT "False" -> <:vala< "False_" >> ] ]
;
label_declarations:
[ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
| ld = label_declaration; ";" -> [ld]
| ld = label_declaration -> [ld] ] ]
;
label_declaration:
[ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
| "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
;
(* Core types *)
ctyp:
[ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
| "arrow" RIGHTA
[ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
| "star"
[ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "apply") SEP "*" ->
<:ctyp< ( $list:[t :: tl]$ ) >> ]
| "apply"
[ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
| "ctyp2"
[ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
| t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
| "simple"
[ "'"; i = V ident "" -> <:ctyp< '$_:i$ >>
| "_" -> <:ctyp< _ >>
| i = V LIDENT -> <:ctyp< $_lid:i$ >>
| i = V UIDENT -> <:ctyp< $_uid:i$ >>
| "("; "module"; mt = module_type; ")" -> <:ctyp< module $mt$ >>
| "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
i = ctyp LEVEL "ctyp2" ->
List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
| "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
;
(* Identifiers *)
ident:
[ [ i = LIDENT -> i
| i = UIDENT -> i ] ]
;
mod_ident:
[ RIGHTA
[ i = UIDENT -> [i]
| i = LIDENT -> [i]
| i = UIDENT; "."; j = SELF -> [i :: j] ] ]
;
(* Miscellaneous *)
direction_flag:
[ [ "to" -> True
| "downto" -> False ] ]
;
(* Objects and Classes *)
str_item:
[ [ "class"; cd = V (LIST1 class_declaration SEP "and") ->
<:str_item< class $_list:cd$ >>
| "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
<:str_item< class type $_list:ctd$ >> ] ]
;
sig_item:
[ [ "class"; cd = V (LIST1 class_description SEP "and") ->
<:sig_item< class $_list:cd$ >>
| "class"; "type"; ctd = V (LIST1 class_type_declaration SEP "and") ->
<:sig_item< class type $_list:ctd$ >> ] ]
;
(* Class expressions *)
class_declaration:
[ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; i = V LIDENT;
cfb = class_fun_binding ->
{MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
MLast.ciNam = i; MLast.ciExp = cfb} ] ]
;
class_fun_binding:
[ [ "="; ce = class_expr -> ce
| ":"; ct = class_type; "="; ce = class_expr ->
<:class_expr< ($ce$ : $ct$) >>
| p = patt LEVEL "simple"; cfb = SELF ->
<:class_expr< fun $p$ -> $cfb$ >> ] ]
;
class_type_parameters:
[ [ -> (loc, <:vala< [] >>)
| "["; tpl = V (LIST1 type_parameter SEP ","); "]" -> (loc, tpl) ] ]
;
class_fun_def:
[ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
<:class_expr< fun $p$ -> $ce$ >>
| p = patt LEVEL "simple"; cfd = SELF ->
<:class_expr< fun $p$ -> $cfd$ >> ] ]
;
class_expr:
[ "top"
[ "fun"; cfd = class_fun_def -> cfd
| "let"; rf = V (FLAG "rec"); lb = V (LIST1 let_binding SEP "and");
"in"; ce = SELF ->
<:class_expr< let $_flag:rf$ $_list:lb$ in $ce$ >> ]
| "apply" LEFTA
[ ce = SELF; e = expr LEVEL "label" ->
<:class_expr< $ce$ $e$ >> ]
| "simple"
[ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
ci = class_longident ->
<:class_expr< [ $list:[ct :: ctcl]$ ] $list:ci$ >>
| "["; ct = ctyp; "]"; ci = class_longident ->
<:class_expr< [ $ct$ ] $list:ci$ >>
| ci = class_longident -> <:class_expr< $list:ci$ >>
| "object"; cspo = V (OPT class_self_patt);
cf = V class_structure "list"; "end" ->
<:class_expr< object $_opt:cspo$ $_list:cf$ end >>
| "("; ce = SELF; ":"; ct = class_type; ")" ->
<:class_expr< ($ce$ : $ct$) >>
| "("; ce = SELF; ")" -> ce ] ]
;
class_structure:
[ [ cf = LIST0 class_str_item -> cf ] ]
;
class_self_patt:
[ [ "("; p = patt; ")" -> p
| "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
;
class_str_item:
[ [ "inherit"; ce = class_expr; pb = V (OPT [ "as"; i = LIDENT -> i ]) ->
<:class_str_item< inherit $ce$ $_opt:pb$ >>
| "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
lab = V LIDENT "lid" ""; e = cvalue_binding ->
<:class_str_item< value $_!:ov$ $_flag:mf$ $_lid:lab$ = $e$ >>
| "val"; ov = V (FLAG "!") "!"; mf = V (FLAG "mutable");
"virtual"; lab = V LIDENT "lid" ""; ":"; t = ctyp ->
if Pcaml.unvala ov then
Ploc.raise loc (Stream.Error "virtual value cannot override")
else
<:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
| "val"; "virtual"; mf = V (FLAG "mutable"); lab = V LIDENT "lid" "";
":"; t = ctyp ->
<:class_str_item< value virtual $_flag:mf$ $_lid:lab$ : $t$ >>
| "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
t = poly_type ->
<:class_str_item< method virtual private $_lid:l$ : $t$ >>
| "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
t = poly_type ->
<:class_str_item< method virtual private $_lid:l$ : $t$ >>
| "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
<:class_str_item< method virtual $_lid:l$ : $t$ >>
| "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
":"; t = poly_type; "="; e = expr ->
<:class_str_item< method $_!:ov$ private $_lid:l$ : $t$ = $e$ >>
| "method"; ov = V (FLAG "!") "!"; "private"; l = V LIDENT "lid" "";
sb = fun_binding ->
<:class_str_item< method $_!:ov$ private $_lid:l$ = $sb$ >>
| "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" ""; ":";
t = poly_type; "="; e = expr ->
<:class_str_item< method $_!:ov$ $_lid:l$ : $t$ = $e$ >>
| "method"; ov = V (FLAG "!") "!"; l = V LIDENT "lid" "";
sb = fun_binding ->
<:class_str_item< method $_!:ov$ $_lid:l$ = $sb$ >>
| "constraint"; t1 = ctyp; "="; t2 = ctyp ->
<:class_str_item< type $t1$ = $t2$ >>
| "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
;
cvalue_binding:
[ [ "="; e = expr -> e
| ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
| ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
<:expr< ($e$ : $t$ :> $t2$) >>
| ":>"; t = ctyp; "="; e = expr ->
<:expr< ($e$ :> $t$) >> ] ]
;
label:
[ [ i = LIDENT -> i ] ]
;
(* Class types *)
class_type:
[ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
<:class_type< [ $t$ ] -> $ct$ >>
| cs = class_signature -> cs ] ]
;
class_signature:
[ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = SELF ->
<:class_type< $id$ [ $list:tl$ ] >>
| "object"; cst = V (OPT class_self_type);
csf = V (LIST0 class_sig_item); "end" ->
<:class_type< object $_opt:cst$ $_list:csf$ end >> ]
| [ ct1 = SELF; "."; ct2 = SELF -> <:class_type< $ct1$ . $ct2$ >>
| ct1 = SELF; "("; ct2 = SELF; ")" -> <:class_type< $ct1$ $ct2$ >> ]
| [ i = V LIDENT -> <:class_type< $_id: i$ >>
| i = V UIDENT -> <:class_type< $_id: i$ >> ] ]
;
class_self_type:
[ [ "("; t = ctyp; ")" -> t ] ]
;
class_sig_item:
[ [ "inherit"; cs = class_signature ->
<:class_sig_item< inherit $cs$ >>
| "val"; mf = V (FLAG "mutable"); l = V LIDENT "lid" ""; ":"; t = ctyp ->
<:class_sig_item< value $_flag:mf$ $_lid:l$ : $t$ >>
| "method"; "private"; "virtual"; l = V LIDENT "lid" ""; ":";
t = poly_type ->
<:class_sig_item< method virtual private $_lid:l$ : $t$ >>
| "method"; "virtual"; "private"; l = V LIDENT "lid" ""; ":";
t = poly_type ->
<:class_sig_item< method virtual private $_lid:l$ : $t$ >>
| "method"; "virtual"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
<:class_sig_item< method virtual $_lid:l$ : $t$ >>
| "method"; "private"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
<:class_sig_item< method private $_lid:l$ : $t$ >>
| "method"; l = V LIDENT "lid" ""; ":"; t = poly_type ->
<:class_sig_item< method $_lid:l$ : $t$ >>
| "constraint"; t1 = ctyp; "="; t2 = ctyp ->
<:class_sig_item< type $t1$ = $t2$ >> ] ]
;
class_description:
[ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
":"; ct = class_type ->
{MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = ct} ] ]
;
class_type_declaration:
[ [ vf = V (FLAG "virtual"); ctp = class_type_parameters; n = V LIDENT;
"="; cs = class_signature ->
{MLast.ciLoc = loc; MLast.ciVir = vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = cs} ] ]
;
(* Expressions *)
expr: LEVEL "simple"
[ LEFTA
[ "new"; i = V class_longident "list" -> <:expr< new $_list:i$ >>
| "object"; cspo = V (OPT class_self_patt);
cf = V class_structure "list"; "end" ->
<:expr< object $_opt:cspo$ $_list:cf$ end >> ] ]
;
expr: LEVEL "."
[ [ e = SELF; "#"; lab = V LIDENT "lid" -> <:expr< $e$ # $_lid:lab$ >> ] ]
;
expr: LEVEL "simple"
[ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
<:expr< ($e$ : $t$ :> $t2$) >>
| "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
| "{<"; ">}" -> <:expr< {< >} >>
| "{<"; fel = V field_expr_list "list"; ">}" ->
<:expr< {< $_list:fel$ >} >> ] ]
;
field_expr_list:
[ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
[(l, e) :: fel]
| l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
| l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
;
(* Core types *)
ctyp: LEVEL "simple"
[ [ "#"; id = V class_longident "list" ->
<:ctyp< # $_list:id$ >>
| "<"; ml = V meth_list "list"; v = V (FLAG ".."); ">" ->
<:ctyp< < $_list:ml$ $_flag:v$ > >>
| "<"; ".."; ">" ->
<:ctyp< < .. > >>
| "<"; ">" ->
<:ctyp< < > >> ] ]
;
meth_list:
[ [ f = field; ";"; ml = SELF -> [f :: ml]
| f = field; ";" -> [f]
| f = field -> [f] ] ]
;
field:
[ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
;
(* Polymorphic types *)
typevar:
[ [ "'"; i = ident -> i ] ]
;
poly_type:
[ [ "type"; nt = LIST1 LIDENT; "."; ct = ctyp ->
<:ctyp< type $list:nt$ . $ct$ >>
| test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
<:ctyp< ! $list:tpl$ . $t2$ >>
| t = ctyp -> t ] ]
;
(* Identifiers *)
class_longident:
[ [ m = UIDENT; "."; l = SELF -> [m :: l]
| i = LIDENT -> [i] ] ]
;
(* Labels *)
ctyp: AFTER "arrow"
[ NONA
[ i = V LIDENT; ":"; t = SELF -> <:ctyp< ~$_:i$: $t$ >>
| i = V QUESTIONIDENTCOLON; t = SELF -> <:ctyp< ?$_:i$: $t$ >>
| i = V QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ?$_:i$: $t$ >> ] ]
;
ctyp: LEVEL "simple"
[ [ "["; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
<:ctyp< [ = $_list:rfl$ ] >>
| "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
| "["; ">"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
<:ctyp< [ > $_list:rfl$ ] >>
| "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); "]" ->
<:ctyp< [ < $_list:rfl$ ] >>
| "[<"; OPT "|"; rfl = V (LIST1 poly_variant SEP "|"); ">";
ntl = V (LIST1 name_tag); "]" ->
<:ctyp< [ < $_list:rfl$ > $_list:ntl$ ] >> ] ]
;
poly_variant:
[ [ "`"; i = V ident "" -> <:poly_variant< ` $_:i$ >>
| "`"; i = V ident ""; "of"; ao = V (FLAG "&");
l = V (LIST1 ctyp SEP "&") ->
<:poly_variant< `$_:i$ of $_flag:ao$ $_list:l$ >>
| t = ctyp -> <:poly_variant< $t$ >> ] ]
;
name_tag:
[ [ "`"; i = ident -> i ] ]
;
expr: LEVEL "expr1"
[ [ "fun"; p = labeled_patt; (eo, e) = fun_def ->
<:expr< fun [ $p$ $opt:eo$ -> $e$ ] >> ] ]
;
expr: AFTER "apply"
[ "label"
[ i = V TILDEIDENTCOLON; e = SELF -> <:expr< ~{$_:i$ = $e$} >>
| i = V TILDEIDENT -> <:expr< ~{$_:i$} >>
| i = V QUESTIONIDENTCOLON; e = SELF -> <:expr< ?{$_:i$ = $e$} >>
| i = V QUESTIONIDENT -> <:expr< ?{$_:i$} >> ] ]
;
expr: LEVEL "simple"
[ [ "`"; s = V ident "" -> <:expr< ` $_:s$ >> ] ]
;
fun_def:
[ [ p = labeled_patt; (eo, e) = SELF ->
(None, <:expr< fun [ $p$ $opt:eo$ -> $e$ ] >>) ] ]
;
fun_binding:
[ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
;
patt: LEVEL "simple"
[ [ "`"; s = V ident "" -> <:patt< ` $_:s$ >>
| "#"; t = V mod_ident "list" "" -> <:patt< # $_list:t$ >>
| p = labeled_patt -> p ] ]
;
labeled_patt:
[ [ i = V TILDEIDENTCOLON; p = patt LEVEL "simple" ->
<:patt< ~{$_:i$ = $p$} >>
| i = V TILDEIDENT ->
<:patt< ~{$_:i$} >>
| "~"; "("; i = LIDENT; ")" ->
<:patt< ~{$lid:i$} >>
| "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
<:patt< ~{$lid:i$ : $t$} >>
| i = V QUESTIONIDENTCOLON; j = LIDENT ->
<:patt< ?{$_:i$ = ?{$lid:j$}} >>
| i = V QUESTIONIDENTCOLON; "_" ->
<:patt< ?{$_:i$} >>
| i = V QUESTIONIDENTCOLON; "("; p = patt; "="; e = expr; ")" ->
<:patt< ?{$_:i$ = ?{$p$ = $e$}} >>
| i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; ")" ->
<:patt< ?{$_:i$ = ?{$p$ : $t$}} >>
| i = V QUESTIONIDENTCOLON; "("; p = patt; ":"; t = ctyp; "=";
e = expr; ")" ->
<:patt< ?{$_:i$ = ?{$p$ : $t$ = $e$}} >>
| i = V QUESTIONIDENTCOLON; "("; p = patt; ")" ->
<:patt< ?{$_:i$ = ?{$p$}} >>
| i = V QUESTIONIDENT -> <:patt< ?{$_:i$} >>
| "?"; "("; i = LIDENT; "="; e = expr; ")" ->
<:patt< ?{$lid:i$ = $e$} >>
| "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
<:patt< ?{$lid:i$ : $t$ = $e$} >>
| "?"; "("; i = LIDENT; ")" ->
<:patt< ?{$lid:i$} >>
| "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
<:patt< ?{$lid:i$ : $t$} >> ] ]
;
class_type:
[ [ i = LIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
<:class_type< [ ~$i$: $t$ ] -> $ct$ >>
| i = V QUESTIONIDENTCOLON; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
<:class_type< [ ?$_:i$: $t$ ] -> $ct$ >>
| i = V QUESTIONIDENT; ":"; t = ctyp LEVEL "apply"; "->"; ct = SELF ->
<:class_type< [ ?$_:i$: $t$ ] -> $ct$ >> ] ]
;
class_fun_binding:
[ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
;
class_fun_def:
[ [ p = labeled_patt; "->"; ce = class_expr ->
<:class_expr< fun $p$ -> $ce$ >>
| p = labeled_patt; cfd = SELF ->
<:class_expr< fun $p$ -> $cfd$ >> ] ]
;
END;
(* Main entry points *)
EXTEND
GLOBAL: interf implem use_file top_phrase expr patt;
interf:
[ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| "#"; n = LIDENT; dp = OPT expr; ";;" ->
([(<:sig_item< # $lid:n$ $opt:dp$ >>, loc)], None)
| EOI -> ([], Some loc) ] ]
;
sig_item_semi:
[ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
;
implem:
[ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| "#"; n = LIDENT; dp = OPT expr; ";;" ->
([(<:str_item< # $lid:n$ $opt:dp$ >>, loc)], None)
| EOI -> ([], Some loc) ] ]
;
str_item_semi:
[ [ si = str_item; OPT ";;" -> (si, loc) ] ]
;
top_phrase:
[ [ ph = phrase; ";;" -> Some ph
| EOI -> None ] ]
;
use_file:
[ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
([si :: sil], stopped)
| "#"; n = LIDENT; dp = OPT expr; ";;" ->
([<:str_item< # $lid:n$ $opt:dp$ >>], True)
| EOI -> ([], False) ] ]
;
phrase:
[ [ sti = str_item -> sti
| "#"; n = LIDENT; dp = OPT expr ->
<:str_item< # $lid:n$ $opt:dp$ >> ] ]
;
END;
Pcaml.add_option "-no_quot" (Arg.Set no_quotations)
"Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
(* ------------------------------------------------------------------------- *)
(* Added by JRH *** *)
(* ------------------------------------------------------------------------- *)
EXTEND
expr: AFTER "<"
[[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
| f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
| f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
| f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
| f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
| f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
| f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
| f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
| f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
| f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
]];
END;
EXTEND
top_phrase:
[ [ sti = str_item; ";;" ->
match sti with
[ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>
| x -> Some x ] ] ]
;
END;