Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

merge branches/implicit-unpack + update camlp4 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10738 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2010-10-21 23:59:33 +00:00
parent 9498d009f0
commit ce605c042a
30 changed files with 707 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Makefile
View File

@ -686,7 +686,7 @@ alldepend::
# Camlp4
camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte
camlp4out: ocamlc ocamlbuild.byte
./build/camlp4-byte-only.sh
camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
@ -694,19 +694,20 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
# Ocamlbuild
ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot
ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot
./build/ocamlbuild-byte-only.sh
ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot
./build/ocamlbuild-native-only.sh
ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot
./build/ocamlbuildlib-native-only.sh
ocamlbuild-mixed-boot: ocamlc otherlibraries
ocamlbuild-mixed-boot: ocamlc
./build/mixed-boot.sh
touch ocamlbuild-mixed-boot
partialclean::
rm -rf _build
rm -rf _build ocamlbuild-mixed-boot
# Check that the stack limit is reasonable.

2
VERSION
View File

@ -1,4 +1,4 @@
3.13.0+dev1 (2010-08-02)
3.13.0+dev2 (2010-10-22)
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

3
camlp4/Camlp4/Camlp4Ast.partial.ml
View File

@ -116,7 +116,8 @@
| PaTyc of loc and patt and ctyp (* (p : t) *)
| PaTyp of loc and ident (* #i *)
| PaVrn of loc and string (* `s *)
| PaLaz of loc and patt (* lazy p *) ]
| PaLaz of loc and patt (* lazy p *)
| PaMod of loc and string (* (module M) *) ]
and expr =
[ ExNil of loc
| ExId of loc and ident (* i *)

1
camlp4/Camlp4/Printers/OCaml.ml
View File

@ -653,6 +653,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
| <:patt< $id:i$ >> -> o#var_ident f i
| <:patt< $anti:s$ >> -> o#anti f s
| <:patt< _ >> -> pp f "_"
| <:patt< ( module $m$ ) >> -> pp f "(module %s)" m
| <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p
| <:patt< { $p$ } >> -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
| <:patt< $str:s$ >> -> pp f "\"%s\"" s

1
camlp4/Camlp4/Struct/Camlp4Ast.mlast
View File

@ -123,6 +123,7 @@ module Make (Loc : Sig.Loc)
| <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
| <:patt< lazy $p$ >> -> is_irrefut_patt p
| <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *)
| <:patt< (module $_$) >> -> True
| <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> |
<:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> |
<:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> |

17
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -538,6 +538,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
| PaVrn loc s -> mkpat loc (Ppat_variant s None)
| PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
| PaMod loc m -> mkpat loc (Ppat_unpack m)
| PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
error (loc_of_patt p) "invalid pattern" ]
and mklabpat =
@ -776,9 +777,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| <:expr@loc< let open $i$ in $e$ >> ->
mkexp loc (Pexp_open (long_uident i) (expr e))
| <:expr@loc< (module $me$ : $pt$) >> ->
mkexp loc (Pexp_pack (module_expr me) (package_type pt))
| <:expr@loc< (module $_$) >> ->
error loc "(module_expr : package_type) expected here"
mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)),
Some (mktyp loc (Ptyp_package (package_type pt))), None))
| <:expr@loc< (module $me$) >> ->
mkexp loc (Pexp_pack (module_expr me))
| ExFUN loc i e ->
mkexp loc (Pexp_newtype i (expr e))
| <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
@ -918,9 +920,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| <:module_expr@loc< ($me$ : $mt$) >> ->
mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
| <:module_expr@loc< (value $e$ : $pt$) >> ->
mkmod loc (Pmod_unpack (expr e) (package_type pt))
| <:module_expr@loc< (value $_$) >> ->
error loc "(value expr) not supported yet"
mkmod loc (Pmod_unpack (
mkexp loc (Pexp_constraint (expr e,
Some (mktyp loc (Ptyp_package (package_type pt))),
None))))
| <:module_expr@loc< (value $e$) >> ->
mkmod loc (Pmod_unpack (expr e))
| <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ]
and str_item s l =
match s with

3
camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
View File

@ -341,6 +341,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
| "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
| "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
| "("; ")" -> <:patt< () >>
| "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
| "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
<:patt< ((module $m$) : (module $pt$)) >>
| "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
| "("; p = patt; ")" -> <:patt< $p$ >>
| "_" -> <:patt< _ >>

6
camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
View File

@ -890,6 +890,9 @@ Very old (no more supported) syntax:\n\
| "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
| "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
| "("; ")" -> <:patt< () >>
| "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
| "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
<:patt< ((module $m$) : (module $pt$)) >>
| "("; p = SELF; ")" -> p
| "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
| "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
@ -958,6 +961,9 @@ Very old (no more supported) syntax:\n\
<:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >>
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag
| "("; ")" -> <:patt< () >>
| "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
| "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
<:patt< ((module $m$) : (module $pt$)) >>
| "("; p = SELF; ")" -> p
| "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
| "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>

123
camlp4/boot/Camlp4.ml
View File

@ -1023,7 +1023,9 @@ module Sig =
PaVrn of loc * string
| (* `s *)
PaLaz of loc * patt
and (* lazy p *)
| (* lazy p *)
PaMod of loc * string
and (* (module M) *)
expr =
| ExNil of loc
| ExId of loc * ident
@ -1929,6 +1931,7 @@ module Sig =
| PaTyp of loc * ident
| PaVrn of loc * string
| PaLaz of loc * patt
| PaMod of loc * string
and expr =
| ExNil of loc
| ExId of loc * ident
@ -7027,6 +7030,7 @@ module Struct =
| Ast.PaLab (_, _, p) -> is_irrefut_patt p
| Ast.PaLaz (_, p) -> is_irrefut_patt p
| Ast.PaId (_, _) -> false
| Ast.PaMod (_, _) -> true
| Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) |
Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) |
Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _)
@ -9081,6 +9085,15 @@ module Struct =
(Ast.IdUid (_loc, "OvOverride")))))
and meta_patt _loc =
function
| Ast.PaMod (x0, x1) ->
Ast.ExApp (_loc,
(Ast.ExApp (_loc,
(Ast.ExId (_loc,
(Ast.IdAcc (_loc,
(Ast.IdUid (_loc, "Ast")),
(Ast.IdUid (_loc, "PaMod")))))),
(meta_loc _loc x0))),
(meta_string _loc x1))
| Ast.PaLaz (x0, x1) ->
Ast.ExApp (_loc,
(Ast.ExApp (_loc,
@ -11367,6 +11380,15 @@ module Struct =
(Ast.IdUid (_loc, "OvOverride")))))
and meta_patt _loc =
function
| Ast.PaMod (x0, x1) ->
Ast.PaApp (_loc,
(Ast.PaApp (_loc,
(Ast.PaId (_loc,
(Ast.IdAcc (_loc,
(Ast.IdUid (_loc, "Ast")),
(Ast.IdUid (_loc, "PaMod")))))),
(meta_loc _loc x0))),
(meta_string _loc x1))
| Ast.PaLaz (x0, x1) ->
Ast.PaApp (_loc,
(Ast.PaApp (_loc,
@ -12370,6 +12392,9 @@ module Struct =
| PaLaz (_x, _x_i1) ->
let _x = o#loc _x in
let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1)
| PaMod (_x, _x_i1) ->
let _x = o#loc _x in
let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1)
method override_flag : override_flag -> override_flag =
function
@ -13274,6 +13299,8 @@ module Struct =
let o = o#loc _x in let o = o#string _x_i1 in o
| PaLaz (_x, _x_i1) ->
let o = o#loc _x in let o = o#patt _x_i1 in o
| PaMod (_x, _x_i1) ->
let o = o#loc _x in let o = o#string _x_i1 in o
method override_flag : override_flag -> 'self_type =
function
@ -14795,6 +14822,7 @@ module Struct =
| PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))
| PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
| PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))
| PaMod (loc, m) -> mkpat loc (Ppat_unpack m)
| (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _
as p) -> error (loc_of_patt p) "invalid pattern"
and mklabpat =
@ -15096,9 +15124,12 @@ module Struct =
| Ast.ExOpI (loc, i, e) ->
mkexp loc (Pexp_open ((long_uident i), (expr e)))
| Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) ->
mkexp loc (Pexp_pack ((module_expr me), (package_type pt)))
| Ast.ExPkg (loc, _) ->
error loc "(module_expr : package_type) expected here"
mkexp loc
(Pexp_constraint
(((mkexp loc (Pexp_pack (module_expr me))),
(Some (mktyp loc (Ptyp_package (package_type pt)))),
None)))
| Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me))
| ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e)))
| Ast.ExCom (loc, _, _) ->
error loc "expr, expr: not allowed here"
@ -15265,9 +15296,15 @@ module Struct =
mkmod loc
(Pmod_constraint ((module_expr me), (module_type mt)))
| Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) ->
mkmod loc (Pmod_unpack ((expr e), (package_type pt)))
| Ast.MePkg (loc, _) ->
error loc "(value expr) not supported yet"
mkmod loc
(Pmod_unpack
(mkexp loc
(Pexp_constraint
(((expr e),
(Some
(mktyp loc (Ptyp_package (package_type pt)))),
None)))))
| Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e))
| Ast.MeAnt (loc, _) ->
error loc "antiquotation in module_expr"
and str_item s l =
@ -16333,6 +16370,12 @@ module Struct =
module Tools =
struct
type prev_locs =
{ mutable pl_strm : Obj.t; mutable pl_locs : (int * Obj.t) list
}
let prev_locs = ref ([] : prev_locs list)
module Make (Structure : Structure.S) =
struct
open Structure
@ -16354,25 +16397,42 @@ module Struct =
match Stream.peek strm with
| None -> Stream.sempty
| Some ((_, init_loc)) ->
let myrecord =
{
pl_strm = Obj.repr Stream.sempty;
pl_locs = [ (0, (Obj.repr init_loc)) ];
} in
let rec go prev_loc (__strm : _ Stream.t) =
(match Stream.peek __strm with
| Some ((tok, cur_loc)) ->
(Stream.junk __strm;
let strm = __strm
in
Stream.lcons
(fun _ ->
(tok,
{
prev_loc = prev_loc;
cur_loc = cur_loc;
}))
(Stream.slazy (fun _ -> go cur_loc strm)))
| _ -> Stream.sempty)
in go init_loc strm
(myrecord.pl_locs <-
myrecord.pl_locs @
[ ((Stream.count strm),
(Obj.repr cur_loc)) ];
Stream.lcons
(fun _ ->
(tok,
{
prev_loc = prev_loc;
cur_loc = cur_loc;
}))
(Stream.slazy (fun _ -> go cur_loc strm))))
| _ ->
(prev_locs :=
List.filter (( != ) myrecord) !prev_locs;
Stream.
sempty)) in
let result = go init_loc strm
in
(prev_locs := myrecord :: !prev_locs;
myrecord.pl_strm <- Obj.repr result;
result)
let drop_prev_loc strm =
stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm
stream_map (fun (tok, r) -> (tok, r)) strm
let get_cur_loc strm =
match Stream.peek strm with
@ -16380,9 +16440,29 @@ module Struct =
| None -> Loc.ghost
let get_prev_loc strm =
match Stream.peek strm with
| Some ((_, r)) -> r.prev_loc
| None -> Loc.ghost
let c = Stream.count strm in
let rec drop l =
match l with
| [] -> []
| (i, _) :: ll -> if i < c then drop ll else l in
let rec find l =
match l with
| [] -> None
| h :: t ->
if h.pl_strm == (Obj.repr strm)
then Some h
else find t
in
match find !prev_locs with
| None -> Loc.ghost
| Some r ->
(r.pl_locs <- drop r.pl_locs;
(match r.pl_locs with
| [] -> Loc.ghost
| (i, loc) :: _ ->
if i = c
then (Obj.obj loc : Loc.t)
else Loc.ghost))
let is_level_labelled n lev =
match lev.lname with | Some n1 -> n = n1 | None -> false
@ -19616,6 +19696,7 @@ module Printers =
| Ast.PaId (_, i) -> o#var_ident f i
| Ast.PaAnt (_, s) -> o#anti f s
| Ast.PaAny _ -> pp f "_"
| Ast.PaMod (_, m) -> pp f "(module %s)" m
| Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p
| Ast.PaRec (_, p) -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
| Ast.PaStr (_, s) -> pp f "\"%s\"" s

40
camlp4/boot/Camlp4Ast.ml
View File

@ -108,12 +108,12 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
| Ast.PaLab _ _ p -> is_irrefut_patt p
| Ast.PaLaz _ p -> is_irrefut_patt p
| Ast.PaId _ _ -> False
| (* here one need to know the arity of constructors *)
Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
Ast.PaAnt _ _
-> False ];
| (* here one need to know the arity of constructors *) Ast.PaMod _ _
-> True
| Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
Ast.PaAnt _ _ -> False ];
value rec is_constructor =
fun
[ Ast.IdAcc _ _ i -> is_constructor i
@ -1902,7 +1902,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
(Ast.IdUid _loc "OvOverride")) ]
and meta_patt _loc =
fun
[ Ast.PaLaz x0 x1 ->
[ Ast.PaMod x0 x1 ->
Ast.ExApp _loc
(Ast.ExApp _loc
(Ast.ExId _loc
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
(Ast.IdUid _loc "PaMod")))
(meta_loc _loc x0))
(meta_string _loc x1)
| Ast.PaLaz x0 x1 ->
Ast.ExApp _loc
(Ast.ExApp _loc
(Ast.ExId _loc
@ -3970,7 +3978,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
(Ast.IdUid _loc "OvOverride")) ]
and meta_patt _loc =
fun
[ Ast.PaLaz x0 x1 ->
[ Ast.PaMod x0 x1 ->
Ast.PaApp _loc
(Ast.PaApp _loc
(Ast.PaId _loc
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
(Ast.IdUid _loc "PaMod")))
(meta_loc _loc x0))
(meta_string _loc x1)
| Ast.PaLaz x0 x1 ->
Ast.PaApp _loc
(Ast.PaApp _loc
(Ast.PaId _loc
@ -4872,7 +4888,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
let _x = o#loc _x in
let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1
| PaLaz _x _x_i1 ->
let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ];
let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1
| PaMod _x _x_i1 ->
let _x = o#loc _x in
let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ];
method override_flag : override_flag -> override_flag =
fun
[ OvOverride -> OvOverride
@ -5653,7 +5672,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o
| PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o
| PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
| PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ];
| PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o
| PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ];
method override_flag : override_flag -> 'self_type =
fun
[ OvOverride -> o

60
camlp4/boot/camlp4boot.ml
View File

@ -3668,6 +3668,29 @@ Very old (no more supported) syntax:\n\
(Gram.Action.mk
(fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
(p : 'patt))));
([ Gram.Skeyword "("; Gram.Skeyword "module";
Gram.Snterm
(Gram.Entry.obj
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
Gram.Skeyword ":";
Gram.Snterm
(Gram.Entry.obj
(package_type : 'package_type Gram.Entry.t));
Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
_ (_loc : Gram.Loc.t) ->
(Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
(Ast.TyPkg (_loc, pt))) :
'patt))));
([ Gram.Skeyword "("; Gram.Skeyword "module";
Gram.Snterm
(Gram.Entry.obj
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
-> (Ast.PaMod (_loc, m) : 'patt))));
([ Gram.Skeyword "("; Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ _ (_loc : Gram.Loc.t) ->
@ -4116,6 +4139,29 @@ Very old (no more supported) syntax:\n\
(Gram.Action.mk
(fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) ->
(p : 'ipatt))));
([ Gram.Skeyword "("; Gram.Skeyword "module";
Gram.Snterm
(Gram.Entry.obj
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
Gram.Skeyword ":";
Gram.Snterm
(Gram.Entry.obj
(package_type : 'package_type Gram.Entry.t));
Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
_ (_loc : Gram.Loc.t) ->
(Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
(Ast.TyPkg (_loc, pt))) :
'ipatt))));
([ Gram.Skeyword "("; Gram.Skeyword "module";
Gram.Snterm
(Gram.Entry.obj
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
-> (Ast.PaMod (_loc, m) : 'ipatt))));
([ Gram.Skeyword "("; Gram.Skeyword ")" ],
(Gram.Action.mk
(fun _ _ (_loc : Gram.Loc.t) ->
@ -15204,8 +15250,7 @@ module B =
load [ "Camlp4ExceptionTracer" ]
| (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) ->
load [ "Camlp4Profiler" ]
| (* map is now an alias of fold since fold handles map too *)
(("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
| (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
load [ "Camlp4FoldGenerator" ]
| (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) ->
load [ "Camlp4FoldGenerator" ]
@ -15233,6 +15278,7 @@ module B =
in real_load (try find_in_path y with | Not_found -> x));
!rcall_callback ())
(* map is now an alias of fold since fold handles map too *)
let print_warning = eprintf "%a:\n%s@." Loc.print
let rec parse_file dyn_loader name pa getdir =
@ -15308,17 +15354,17 @@ Options:\n\
<file>.%s Load this module inside the Camlp4 core@."
(if DynLoader.is_native then "cmxs " else "(cmo|cma)");
Options.print_usage_list ini_sl;
(* loop (ini_sl @ ext_sl) where rec loop =
fun
[ [(y, _, _) :: _] when y = "-help" -> ()
| [_ :: sl] -> loop sl
| [] -> eprintf " -help Display this list of options.@." ]; *)
if ext_sl <> []
then
(eprintf "Options added by loaded object files:@.";
Options.print_usage_list ext_sl)
else ())
(* loop (ini_sl @ ext_sl) where rec loop =
fun
[ [(y, _, _) :: _] when y = "-help" -> ()
| [_ :: sl] -> loop sl
| [] -> eprintf " -help Display this list of options.@." ]; *)
let warn_noassert () =
eprintf
"\

10
ocamldoc/odoc_ast.ml
View File

@ -1647,7 +1647,7 @@ module Analyser =
m_kind = Module_struct elements2 ;
}
| (Parsetree.Pmod_unpack (p_exp, pkg_type),
| (Parsetree.Pmod_unpack (p_exp),
Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->
print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);
let code =
@ -1658,7 +1658,13 @@ module Analyser =
let s = get_string_of_file exp_loc_end loc_end in
Printf.sprintf "(val ...%s" s
in
let name = Odoc_env.full_module_type_name env (Name.from_longident (fst pkg_type)) in
(* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *)
let name =
match tt_modtype with
| Tmty_ident p ->
Odoc_env.full_module_type_name env (Name.from_path p)
| _ -> ""
in
let alias = { mta_name = name ; mta_module = None } in
{ m_base with
m_type = Odoc_env.subst_module_type env tt_modtype ;

2
otherlibs/labltk/browser/searchid.ml
View File

@ -406,7 +406,7 @@ open Parsetree
let rec bound_variables pat =
match pat.ppat_desc with
Ppat_any | Ppat_constant _ | Ppat_type _ -> []
Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
| Ppat_var s -> [s]
| Ppat_alias (pat,s) -> s :: bound_variables pat
| Ppat_tuple l -> List2.flat_map l ~f:bound_variables

27
parsing/parser.mly
View File

@ -453,10 +453,24 @@ module_expr:
{ $2 }
| LPAREN module_expr error
{ unclosed "(" 1 ")" 3 }
| LPAREN VAL expr RPAREN
{ mkmod(Pmod_unpack $3) }
| LPAREN VAL expr COLON package_type RPAREN
{ mkmod(Pmod_unpack($3, $5)) }
{ mkmod(Pmod_unpack(
ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), None)))) }
| LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN
{ mkmod(Pmod_unpack(
ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)),
Some(ghtyp(Ptyp_package $7)))))) }
| LPAREN VAL expr COLONGREATER package_type RPAREN
{ mkmod(Pmod_unpack(
ghexp(Pexp_constraint($3, None, Some(ghtyp(Ptyp_package $5)))))) }
| LPAREN VAL expr COLON error
{ unclosed "(" 1 ")" 5 }
| LPAREN VAL expr COLONGREATER error
{ unclosed "(" 1 ")" 5 }
| LPAREN VAL expr error
{ unclosed "(" 1 ")" 4 }
;
structure:
structure_tail { $1 }
@ -1021,8 +1035,11 @@ simple_expr:
{ mkexp(Pexp_override []) }
| simple_expr SHARP label
{ mkexp(Pexp_send($1, $3)) }
| LPAREN MODULE module_expr RPAREN
{ mkexp (Pexp_pack $3) }
| LPAREN MODULE module_expr COLON package_type RPAREN
{ mkexp (Pexp_pack ($3, $5)) }
{ mkexp (Pexp_constraint (ghexp (Pexp_pack $3),
Some (ghtyp (Ptyp_package $5)), None)) }
| LPAREN MODULE module_expr COLON error
{ unclosed "(" 1 ")" 5 }
;
@ -1191,6 +1208,12 @@ simple_pattern:
{ mkpat(Ppat_constraint($2, $4)) }
| LPAREN pattern COLON core_type error
{ unclosed "(" 1 ")" 5 }
| LPAREN MODULE UIDENT RPAREN
{ mkpat(Ppat_unpack $3) }
| LPAREN MODULE UIDENT COLON package_type RPAREN
{ mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) }
| LPAREN MODULE UIDENT COLON package_type error
{ unclosed "(" 1 ")" 6 }
;
pattern_comma_list:

5
parsing/parsetree.mli
View File

@ -79,6 +79,7 @@ and pattern_desc =
| Ppat_constraint of pattern * core_type
| Ppat_type of Longident.t
| Ppat_lazy of pattern
| Ppat_unpack of string
type expression =
{ pexp_desc: expression_desc;
@ -116,7 +117,7 @@ and expression_desc =
| Pexp_poly of expression * core_type option
| Pexp_object of class_structure
| Pexp_newtype of string * expression
| Pexp_pack of module_expr * package_type
| Pexp_pack of module_expr
| Pexp_open of Longident.t * expression
(* Value descriptions *)
@ -249,7 +250,7 @@ and module_expr_desc =
| Pmod_functor of string * module_type * module_expr
| Pmod_apply of module_expr * module_expr
| Pmod_constraint of module_expr * module_type
| Pmod_unpack of expression * package_type
| Pmod_unpack of expression
and structure = structure_item list

12
parsing/printast.ml
View File

@ -209,6 +209,8 @@ and pattern i ppf x =
| Ppat_type li ->
line i ppf "Ppat_type";
longident i ppf li
| Ppat_unpack s ->
line i ppf "Ppat_unpack \"%s\"\n" s;
and expression i ppf x =
line i ppf "expression %a\n" fmt_location x.pexp_loc;
@ -321,9 +323,8 @@ and expression i ppf x =
| Pexp_newtype (s, e) ->
line i ppf "Pexp_newtype \"%s\"\n" s;
expression i ppf e
| Pexp_pack (me, (p,l)) ->
line i ppf "Pexp_pack %a" fmt_longident p;
list i package_with ppf l;
| Pexp_pack me ->
line i ppf "Pexp_pack";
module_expr i ppf me
| Pexp_open (m, e) ->
line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
@ -593,9 +594,8 @@ and module_expr i ppf x =
line i ppf "Pmod_constraint\n";
module_expr i ppf me;
module_type i ppf mt;
| Pmod_unpack (e, (p, l)) ->
line i ppf "Pmod_unpack %a\n" fmt_longident p;
list i package_with ppf l;
| Pmod_unpack (e) ->
line i ppf "Pmod_unpack\n";
expression i ppf e;
and structure i ppf x = list i structure_item ppf x

116
testlabl/implicit_unpack.ml Normal file
View File

@ -0,0 +1,116 @@
(*
Implicit unpack allows to omit the signature in (val ...) expressions.
It also adds (module M : S) and (module M) patterns, relying on
implicit (val ...) for the implementation. Such patterns can only
be used in function definition, match clauses, and let ... in.
New: implicit pack is also supported, and you only need to be able
to infer the the module type path from the context.
*)
(* ocaml -principal *)
(* Use a module pattern *)
let sort (type s) (module Set : Set.S with type elt = s) l =
Set.elements (List.fold_right Set.add l Set.empty)
(* No real improvement here? *)
let make_set (type s) cmp : (module Set.S with type elt = s) =
(module Set.Make (struct type t = s let compare = cmp end))
(* No type annotation here *)
let sort_cmp (type s) cmp =
sort (module Set.Make (struct type t = s let compare = cmp end))
module type S = sig type t val x : t end;;
let f (module M : S with type t = int) = M.x;;
let f (module M : S with type t = 'a) = M.x;; (* Error *)
let f (type a) (module M : S with type t = a) = M.x;;
f (module struct type t = int let x = 1 end);;
type 'a s = {s: (module S with type t = 'a)};;
{s=(module struct type t = int let x = 1 end)};;
let f {s=(module M)} = M.x;; (* Error *)
let f (type a) ({s=(module M)} : a s) = M.x;;
type s = {s: (module S with type t = int)};;
let f {s=(module M)} = M.x;;
let f {s=(module M)} {s=(module N)} = M.x + N.x;;
module type S = sig val x : int end;;
let f (module M : S) y (module N : S) = M.x + y + N.x;;
let m = (module struct let x = 3 end);; (* Error *)
let m = (module struct let x = 3 end : S);;
f m 1 m;;
f m 1 (module struct let x = 2 end);;
let (module M) = m in M.x;;
let (module M) = m;; (* Error: only allowed in [let .. in] *)
class c = let (module M) = m in object end;; (* Error again *)
module M = (val m);;
module type S' = sig val f : int -> int end;;
(* Even works with recursion, but must be fully explicit *)
let rec (module M : S') =
(module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
in M.f 3;;
(* Subtyping *)
module type S = sig type t type u val x : t * u end
let f (l : (module S with type t = int and type u = bool) list) =
(l :> (module S with type u = bool) list)
(* GADTs from the manual *)
(* the only modification is in to_string *)
module TypEq : sig
type ('a, 'b) t
val apply: ('a, 'b) t -> 'a -> 'b
val refl: ('a, 'a) t
val sym: ('a, 'b) t -> ('b, 'a) t
end = struct
type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
let refl = (fun x -> x), (fun x -> x)
let apply (f, _) x = f x
let sym (f, g) = (g, f)
end
module rec Typ : sig
module type PAIR = sig
type t and t1 and t2
val eq: (t, t1 * t2) TypEq.t
val t1: t1 Typ.typ
val t2: t2 Typ.typ
end
type 'a typ =
| Int of ('a, int) TypEq.t
| String of ('a, string) TypEq.t
| Pair of (module PAIR with type t = 'a)
end = Typ
let int = Typ.Int TypEq.refl
let str = Typ.String TypEq.refl
let pair (type s1) (type s2) t1 t2 =
let module P = struct
type t = s1 * s2
type t1 = s1
type t2 = s2
let eq = TypEq.refl
let t1 = t1
let t2 = t2
end in
Typ.Pair (module P)
open Typ
let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
fun (type s) t x ->
match (t : s typ) with
| Int eq -> string_of_int (TypEq.apply eq x)
| String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
| Pair (module P) ->
let (x1, x2) = TypEq.apply P.eq x in
Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)

2
tools/addlabels.ml
View File

@ -64,7 +64,7 @@ let rec pattern_vars pat =
pattern_vars pat1 @ pattern_vars pat2
| Ppat_lazy pat -> pattern_vars pat
| Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
| Ppat_type _ ->
| Ppat_type _ | Ppat_unpack _ ->
[]
let pattern_name pat =

6
tools/depend.ml
View File

@ -118,6 +118,7 @@ let rec add_pattern bv pat =
| Ppat_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type (li) -> add bv li
| Ppat_lazy p -> add_pattern bv p
| Ppat_unpack _ -> ()
let rec add_expr bv exp =
match exp.pexp_desc with
@ -163,7 +164,7 @@ let rec add_expr bv exp =
| Pexp_object (pat, fieldl) ->
add_pattern bv pat; List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack (m, pt) -> add_package_type bv pt; add_module bv m
| Pexp_pack m -> add_module bv m
| Pexp_open (m, e) -> addmodule bv m; add_expr bv e
and add_pat_expr_list bv pel =
List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
@ -228,8 +229,7 @@ and add_module bv modl =
add_module bv mod1; add_module bv mod2
| Pmod_constraint(modl, mty) ->
add_module bv modl; add_modtype bv mty
| Pmod_unpack(e, pt) ->
add_package_type bv pt;
| Pmod_unpack(e) ->
add_expr bv e
and add_structure bv item_list =

4
tools/ocamlprof.ml
View File

@ -287,7 +287,7 @@ and rw_exp iflag sexp =
| Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
| Pexp_open (_, e) -> rewrite_exp iflag e
| Pexp_pack (smod, _) -> rewrite_mod iflag smod
| Pexp_pack (smod) -> rewrite_mod iflag smod
and rewrite_ifbody iflag ghost sifbody =
if !instr_if && not ghost then
@ -362,7 +362,7 @@ and rewrite_mod iflag smod =
| Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
| Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
| Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
| Pmod_unpack(sexp, _) -> rewrite_exp iflag sexp
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp
and rewrite_str_item iflag item =
match item.pstr_desc with

36
typing/ctype.ml
View File

@ -1927,9 +1927,9 @@ let rec filter_arrow env t l =
let t = expand_head_unif env t in
match t.desc with
Tvar ->
let t1 = newvar () and t2 = newvar () in
let t' = newty (Tarrow (l, t1, t2, Cok)) in
update_level env t.level t';
let lv = t.level in
let t1 = newvar2 lv and t2 = newvar2 lv in
let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
link_type t t';
(t1, t2)
| Tarrow(l', t1, t2, _)
@ -2763,16 +2763,16 @@ let rec filter_visited = function
let memq_warn t visited =
if List.memq t visited then (warn := true; true) else false
let rec lid_of_path sharp = function
let rec lid_of_path ?(sharp="") = function
Path.Pident id ->
Longident.Lident (sharp ^ Ident.name id)
| Path.Pdot (p1, s, _) ->
Longident.Ldot (lid_of_path "" p1, sharp ^ s)
Longident.Ldot (lid_of_path p1, sharp ^ s)
| Path.Papply (p1, p2) ->
Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
let find_cltype_for_path env p =
let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
match cl_abbr.type_manifest with
Some ty ->
begin match (repr ty).desc with
@ -2977,6 +2977,23 @@ let private_abbrev env path =
decl.type_private = Private && decl.type_manifest <> None
with Not_found -> false
(* check list inclusion, assuming lists are ordered *)
let rec included nl1 nl2 =
match nl1, nl2 with
(a::nl1', b::nl2') ->
if a = b then included nl1' nl2' else
a > b && included nl1 nl2'
| ([], _) -> true
| (_, []) -> false
let rec extract_assoc nl1 nl2 tl2 =
match (nl1, nl2, tl2) with
(a::nl1', b::nl2, t::tl2) ->
if a = b then t :: extract_assoc nl1' nl2 tl2
else extract_assoc nl1 nl2 tl2
| ([], _, _) -> []
| _ -> assert false
let rec subtype_rec env trace t1 t2 cstrs =
let t1 = repr t1 in
let t2 = repr t2 in
@ -3047,6 +3064,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
with Unify _ ->
(trace, t1, t2, !univar_pairs)::cstrs
end
| (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2))
when Path.same p1 p2 && included nl2 nl1 ->
List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs))
(extract_assoc nl2 nl1 tl1) tl2
@ cstrs
| (_, _) ->
(trace, t1, t2, !univar_pairs)::cstrs
end

1
typing/ctype.mli
View File

@ -74,6 +74,7 @@ val set_object_name:
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
val lid_of_path: ?sharp:string -> Path.t -> Longident.t
val sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields:

263
typing/typecore.ml
View File

@ -56,6 +56,9 @@ type error =
| Not_a_variant_type of Longident.t
| Incoherent_label_order
| Less_general of string * (type_expr * type_expr) list
| Modules_not_allowed
| Cannot_infer_signature
| Not_a_packed_module of type_expr
exception Error of Location.t * error
@ -70,6 +73,10 @@ let type_module =
let type_open =
ref (fun _ -> assert false)
(* Forward declaration, to be filled in by Typemod.type_package *)
let type_package =
ref (fun _ -> assert false)
(* Forward declaration, to be filled in by Typeclass.class_structure *)
let type_object =
@ -196,20 +203,29 @@ let has_variants p =
let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
let pattern_force = ref ([] : (unit -> unit) list)
let pattern_scope = ref (None : Annot.ident option);;
let reset_pattern scope =
let allow_modules = ref false
let module_variables = ref ([] : (string * Location.t) list)
let reset_pattern scope allow =
pattern_variables := [];
pattern_force := [];
pattern_scope := scope;
allow_modules := allow;
module_variables := [];
;;
let enter_variable loc name ty =
let enter_variable ?(is_module=false) loc name ty =
if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
then raise(Error(loc, Multiply_bound_variable name));
let id = Ident.create name in
pattern_variables := (id, ty, loc) :: !pattern_variables;
begin match !pattern_scope with
| None -> ()
| Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
if is_module then begin
(* Note: unpack patterns enter a variable of the same name *)
if not !allow_modules then raise (Error (loc, Modules_not_allowed));
module_variables := (name, loc) :: !module_variables
end else begin
match !pattern_scope with
| None -> ()
| Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
end;
id
@ -408,6 +424,14 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = ty;
pat_env = env }
| Ppat_unpack name ->
let ty = newvar() in
let id = enter_variable loc name ty ~is_module:true in
rp {
pat_desc = Tpat_var id;
pat_loc = loc;
pat_type = ty;
pat_env = env }
| Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc},
({ptyp_desc=Ptyp_poly _} as sty)) ->
(* explicitly polymorphic type *)
@ -569,27 +593,28 @@ let get_ref r =
let add_pattern_variables env =
let pv = get_ref pattern_variables in
List.fold_right
(List.fold_right
(fun (id, ty, loc) env ->
let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
Env.add_annot id (Annot.Iref_internal loc) e1;
Env.add_annot id (Annot.Iref_internal loc) e1
)
pv env
pv env,
get_ref module_variables)
let type_pattern env spat scope =
reset_pattern scope;
reset_pattern scope true;
let pat = type_pat env spat in
let new_env = add_pattern_variables env in
(pat, new_env, get_ref pattern_force)
let new_env, unpacks = add_pattern_variables env in
(pat, new_env, get_ref pattern_force, unpacks)
let type_pattern_list env spatl scope =
reset_pattern scope;
let type_pattern_list env spatl scope allow =
reset_pattern scope allow;
let patl = List.map (type_pat env) spatl in
let new_env = add_pattern_variables env in
(patl, new_env, get_ref pattern_force)
let new_env, unpacks = add_pattern_variables env in
(patl, new_env, get_ref pattern_force, unpacks)
let type_class_arg_pattern cl_num val_env met_env l spat =
reset_pattern None;
reset_pattern None false;
let pat = type_pat val_env spat in
if has_variants pat then begin
Parmatch.pressure_variants val_env [pat];
@ -607,7 +632,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
env))
!pattern_variables ([], met_env)
in
let val_env = add_pattern_variables val_env in
let val_env, _ = add_pattern_variables val_env in
(pat, pv, val_env, met_env)
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
@ -617,7 +642,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
"selfpat-" ^ cl_num))
in
reset_pattern None;
reset_pattern None false;
let pat = type_pat val_env spat in
List.iter (fun f -> f()) (get_ref pattern_force);
let meths = ref Meths.empty in
@ -1009,6 +1034,16 @@ let create_package_type loc env (p, l) =
List.map fst l,
List.map (Typetexp.transl_simple_type env false) (List.map snd l)))
let wrap_unpacks sexp unpacks =
List.fold_left
(fun sexp (name, loc) ->
{pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
name,
{pmod_loc = loc; pmod_desc = Pmod_unpack
{pexp_desc=Pexp_ident(Longident.Lident name); pexp_loc=loc}},
sexp)})
sexp unpacks
(* Typing of expressions *)
let unify_exp env exp expected_ty =
@ -1077,8 +1112,9 @@ let rec type_exp env sexp =
| Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
| Default -> None
in
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
let body = type_exp new_env sbody in
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list scp true in
let body = type_exp new_env (wrap_unpacks sbody unpacks) in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc;
@ -1116,7 +1152,12 @@ let rec type_exp env sexp =
exp_type = ty_res;
exp_env = env }
| Pexp_match(sarg, caselist) ->
if !Clflags.principal then begin_def ();
let arg = type_exp env sarg in
if !Clflags.principal then begin
end_def ();
generalize_structure arg.exp_type;
end;
let ty_res = newvar() in
let cases, partial =
type_cases env arg.exp_type ty_res (Some loc) caselist
@ -1129,8 +1170,7 @@ let rec type_exp env sexp =
| Pexp_try(sbody, caselist) ->
let body = type_exp env sbody in
let cases, _ =
type_cases
env (instance Predef.type_exn) body.exp_type None caselist in
type_cases env Predef.type_exn body.exp_type None caselist in
re {
exp_desc = Texp_try(body, cases);
exp_loc = loc;
@ -1300,10 +1340,10 @@ let rec type_exp env sexp =
if !Clflags.principal then begin
end_def ();
generalize_structure ty;
let ty1 = instance ty and ty2 = instance ty in
(type_expect env sarg ty1, ty2)
let ty2 = instance ty in
(type_argument env sarg ty, ty2)
end else
(type_expect env sarg ty, ty)
(type_argument env sarg ty, ty)
| (None, Some sty') ->
let (ty', force) =
Typetexp.transl_simple_type_delayed env sty'
@ -1355,6 +1395,7 @@ let rec type_exp env sexp =
end;
(arg, ty')
| (Some sty, Some sty') ->
if !Clflags.principal then begin_def ();
let (ty, force) =
Typetexp.transl_simple_type_delayed env sty
and (ty', force') =
@ -1366,7 +1407,13 @@ let rec type_exp env sexp =
with Subtype (tr1, tr2) ->
raise(Error(loc, Not_subtype(tr1, tr2)))
end;
(type_expect env sarg ty, ty')
if !Clflags.principal then begin
end_def ();
generalize_structure ty;
generalize_structure ty';
(type_argument env sarg ty, instance ty')
end else
(type_argument env sarg ty, ty')
in
re {
exp_desc = arg.exp_desc;
@ -1626,18 +1673,8 @@ let rec type_exp env sexp =
(* non-expansive if the body is non-expansive, so we don't introduce
any new extra node in the typed AST. *)
re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
| Pexp_pack (m, (p, l)) ->
let loc = sexp.pexp_loc in
let l, mty = Typetexp.create_package_mty loc env (p, l) in
let m = {pmod_desc = Pmod_constraint (m, mty); pmod_loc = loc} in
let context = Typetexp.narrow () in
let modl = !type_module env m in
Typetexp.widen context;
re {
exp_desc = Texp_pack modl;
exp_loc = loc;
exp_type = create_package_type loc env (p, l);
exp_env = env }
| Pexp_pack m ->
raise (Error (loc, Cannot_infer_signature))
| Pexp_open (lid, e) ->
type_exp (!type_open env sexp.pexp_loc lid) e
@ -1689,7 +1726,7 @@ and type_argument env sarg ty_expected' =
let ty_expected = instance ty_expected' in
match expand_head env ty_expected', sarg with
| _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
type_expect env sarg ty_expected
type_expect env sarg ty_expected'
| {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
(* apply optional arguments when expected type is "" *)
(* we must be very careful about not breaking the semantics *)
@ -1746,7 +1783,7 @@ and type_argument env sarg ty_expected' =
Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
end
| _ ->
type_expect env sarg ty_expected
type_expect env sarg ty_expected'
and type_application env funct sargs =
(* funct.exp_type may be generic *)
@ -1932,30 +1969,36 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
if List.length sargs <> constr.cstr_arity then
raise(Error(loc, Constructor_arity_mismatch
(lid, constr.cstr_arity, List.length sargs)));
if !Clflags.principal then begin_def ();
if !Clflags.principal then (begin_def (); begin_def ());
let (ty_args, ty_res) = instance_constructor constr in
if !Clflags.principal then begin
end_def ();
List.iter generalize_structure ty_args;
generalize_structure ty_res
end;
let texp =
re {
exp_desc = Texp_construct(constr, []);
exp_loc = loc;
exp_type = instance ty_res;
exp_type = ty_res;
exp_env = env } in
unify_exp env texp ty_expected;
if !Clflags.principal then begin
end_def ();
generalize_structure ty_res;
unify_exp env {texp with exp_type = instance ty_res}
(instance ty_expected);
end_def ();
List.iter generalize_structure ty_args;
generalize_structure ty_res;
end;
let texp = {texp with exp_type = instance ty_res} in
if not !Clflags.principal then unify_exp env texp (instance ty_expected);
let args = List.map2 (type_argument env) sargs ty_args in
if constr.cstr_private = Private then
raise(Error(loc, Private_type ty_res));
{ texp with exp_desc = Texp_construct(constr, args) }
{ texp with exp_desc = Texp_construct(constr, args)}
(* Typing of an expression with an expected type.
Some constructs are treated specially to provide better error messages. *)
and type_expect ?in_function env sexp ty_expected =
and type_expect ?in_function env sexp ty_expected' =
let loc = sexp.pexp_loc in
let ty_expected = instance ty_expected' in
match sexp.pexp_desc with
Pexp_constant(Const_string s as cst) ->
let exp =
@ -1973,10 +2016,31 @@ and type_expect ?in_function env sexp ty_expected =
unify_exp env exp ty_expected;
exp
| Pexp_construct(lid, sarg, explicit_arity) ->
type_construct env loc lid sarg explicit_arity ty_expected
type_construct env loc lid sarg explicit_arity ty_expected'
| Pexp_variant(l, Some sarg) ->
begin try match expand_head env ty_expected' with
| {desc = Tvariant row} ->
let row = row_repr row in
begin match row_field_repr (List.assoc l row.row_fields) with
Rpresent (Some ty) ->
let arg = type_argument env sarg ty in
re { exp_desc = Texp_variant(l, Some arg);
exp_loc = loc;
exp_type = ty_expected;
exp_env = env }
| _ -> raise Not_found
end
| _ -> raise Not_found
with Not_found ->
let exp = type_exp env sexp in
unify_exp env exp ty_expected;
exp
end
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
let body = type_expect new_env sbody ty_expected in
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list None true in
let body =
type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc;
@ -2011,8 +2075,7 @@ and type_expect ?in_function env sexp ty_expected =
pexp_desc =
Pexp_match ({
pexp_loc = loc;
pexp_desc =
Pexp_ident(Longident.Lident "*opt*")
pexp_desc = Pexp_ident(Longident.Lident "*opt*")
},
scases
)
@ -2021,25 +2084,24 @@ and type_expect ?in_function env sexp ty_expected =
pexp_loc = loc;
pexp_desc =
Pexp_function (
l,
None,
l, None,
[ {ppat_loc = loc;
ppat_desc = Ppat_var "*opt*"},
{pexp_loc = loc;
pexp_desc =
Pexp_let(Default, [spat, smatch], sbody);
pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
}
]
)
} in
type_expect ?in_function env sfun ty_expected
type_expect ?in_function env sfun ty_expected'
| Pexp_function (l, _, caselist) ->
let (loc_fun, ty_fun) =
match in_function with Some p -> p
| None -> (loc, ty_expected)
in
if !Clflags.principal then begin_def ();
let (ty_arg, ty_res) =
try filter_arrow env ty_expected l
try filter_arrow env (instance ty_expected') l
with Unify _ ->
match expand_head env ty_expected with
{desc = Tarrow _} as ty ->
@ -2052,12 +2114,17 @@ and type_expect ?in_function env sexp ty_expected =
if is_optional l then
let tv = newvar() in
begin
try unify env ty_arg (type_option tv)
try unify env (instance ty_arg) (type_option tv)
with Unify _ -> assert false
end;
type_option tv
else ty_arg
in
if !Clflags.principal then begin
end_def ();
generalize_structure ty_arg;
generalize_structure ty_res
end;
let cases, partial =
type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
(Some loc) caselist in
@ -2071,7 +2138,7 @@ and type_expect ?in_function env sexp ty_expected =
re {
exp_desc = Texp_function(cases, partial);
exp_loc = loc;
exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
exp_env = env }
| Pexp_when(scond, sbody) ->
let cond = type_expect env scond (instance Predef.type_bool) in
@ -2110,6 +2177,31 @@ and type_expect ?in_function env sexp ty_expected =
re { exp with exp_type = ty }
| _ -> assert false
end
| Pexp_pack m ->
let (p, nl, tl) =
match Ctype.expand_head env ty_expected with
{desc = Tpackage (p, nl, tl)} ->
if !Clflags.principal &&
(Ctype.expand_head env ty_expected').level < Btype.generic_level
then
Location.prerr_warning loc
(Warnings.Not_principal "this module packing");
(p, nl, tl)
| {desc = Tvar} ->
raise (Error (loc, Cannot_infer_signature))
| _ ->
raise (Error (loc, Not_a_packed_module ty_expected))
in
let context = Typetexp.narrow () in
let (modl, tl') = !type_package env m p nl tl in
Typetexp.widen context;
let exp = {
exp_desc = Texp_pack modl;
exp_loc = loc;
exp_type = newty (Tpackage (p, nl, tl'));
exp_env = env } in
unify_exp env exp ty_expected;
re {exp with exp_type = ty_expected}
| _ ->
let exp = type_exp env sexp in
unify_exp env exp ty_expected;
@ -2144,15 +2236,16 @@ and type_statement env sexp =
(* Typing of match cases *)
and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
if !Clflags.principal then begin_def (); (* propagation of the argument *)
let ty_arg' = newvar () in
let pattern_force = ref [] in
let pat_env_list =
List.map
(fun (spat, sexp) ->
let loc = sexp.pexp_loc in
if !Clflags.principal then begin_def ();
if !Clflags.principal then begin_def (); (* propagation of pattern *)
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force) = type_pattern env spat scope in
let (pat, ext_env, force, unpacks) = type_pattern env spat scope in
pattern_force := force @ !pattern_force;
let pat =
if !Clflags.principal then begin
@ -2162,7 +2255,7 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
end else pat
in
unify_pat env pat ty_arg';
(pat, ext_env))
(pat, (ext_env, unpacks)))
caselist in
(* Check for polymorphic variants to close *)
let patl = List.map fst pat_env_list in
@ -2173,14 +2266,23 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
(* `Contaminating' unifications start here *)
List.iter (fun f -> f()) !pattern_force;
begin match pat_env_list with [] -> ()
| (pat, _) :: _ -> unify_pat env pat ty_arg
| (pat, _) :: _ -> unify_pat env pat (instance ty_arg)
end;
if !Clflags.principal then begin
let patl = List.map fst pat_env_list in
List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
patl;
end_def ();
List.iter (iter_pattern (fun {pat_type=t} -> generalize_structure t)) patl
end;
let in_function = if List.length caselist = 1 then in_function else None in
let ty_arg' = instance ty_arg in
let cases =
List.map2
(fun (pat, ext_env) (spat, sexp) ->
(fun (pat, (ext_env, unpacks)) (spat, sexp) ->
let sexp = wrap_unpacks sexp unpacks in
let exp = type_expect ?in_function ext_env sexp ty_res in
(pat, exp))
({pat with pat_type = ty_arg'}, exp))
pat_env_list caselist
in
let partial =
@ -2193,11 +2295,12 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
(* Typing of let bindings *)
and type_let env rec_flag spat_sexp_list scope =
and type_let env rec_flag spat_sexp_list scope allow =
begin_def();
if !Clflags.principal then begin_def ();
let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
let (pat_list, new_env, force) = type_pattern_list env spatl scope in
let (pat_list, new_env, force, unpacks) =
type_pattern_list env spatl scope allow in
if rec_flag = Recursive then
List.iter2
(fun pat (_, sexp) ->
@ -2232,6 +2335,8 @@ and type_let env rec_flag spat_sexp_list scope =
let exp_list =
List.map2
(fun (spat, sexp) pat ->
let sexp =
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
match pat.pat_type.desc with
| Tpoly (ty, tl) ->
begin_def ();
@ -2254,10 +2359,15 @@ and type_let env rec_flag spat_sexp_list scope =
List.iter
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
pat_list;
(List.combine pat_list exp_list, new_env)
(List.combine pat_list exp_list, new_env, unpacks)
(* Typing of toplevel bindings *)
let type_let env rec_flag spat_sexp_list scope =
let (pat_exp_list, new_env, unpacks) =
type_let env rec_flag spat_sexp_list scope false in
(pat_exp_list, new_env)
let type_binding env rec_flag spat_sexp_list scope =
Typetexp.reset_type_variables();
type_let env rec_flag spat_sexp_list scope
@ -2426,3 +2536,12 @@ let report_error ppf = function
report_unification_error ppf trace
(fun ppf -> fprintf ppf "This %s has type" kind)
(fun ppf -> fprintf ppf "which is less general than")
| Modules_not_allowed ->
fprintf ppf "Modules are not allowed in this pattern."
| Cannot_infer_signature ->
fprintf ppf
"The signature for this packaged module couldn't be inferred."
| Not_a_packed_module ty ->
fprintf ppf
"This expression is packed module, but the expected type is@ %a"
type_expr ty

7
typing/typecore.mli
View File

@ -57,6 +57,7 @@ val option_some: Typedtree.expression -> Typedtree.expression
val option_none: type_expr -> Location.t -> Typedtree.expression
val extract_option_type: Env.t -> type_expr -> type_expr
val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
val generalizable: int -> type_expr -> bool
val reset_delayed_checks: unit -> unit
val force_delayed_checks: unit -> unit
@ -96,6 +97,9 @@ type error =
| Not_a_variant_type of Longident.t
| Incoherent_label_order
| Less_general of string * (type_expr * type_expr) list
| Modules_not_allowed
| Cannot_infer_signature
| Not_a_packed_module of type_expr
exception Error of Location.t * error
@ -109,5 +113,8 @@ val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
val type_object:
(Env.t -> Location.t -> Parsetree.class_structure ->
Typedtree.class_structure * class_signature * string list) ref
val type_package:
(Env.t -> Parsetree.module_expr -> Path.t -> string list -> type_expr list ->
Typedtree.module_expr * type_expr list) ref
val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr

106
typing/typemod.ml
View File

@ -39,6 +39,8 @@ type error =
| Interface_not_compiled of string
| Not_allowed_in_functor_body
| With_need_typeconstr
| Not_a_packed_module of type_expr
| Incomplete_packed_module of type_expr
exception Error of Location.t * error
@ -631,6 +633,40 @@ let check_recmodule_inclusion env bindings =
end
in check_incl true (List.length bindings) env Subst.identity
(* Helper for unpack *)
let modtype_of_package env loc p nl tl =
try match Env.find_modtype p env with
| Tmodtype_manifest mty when nl <> [] ->
let sg = extract_sig env loc mty in
let ntl = List.combine nl tl in
let sg' =
List.map
(function
Tsig_type (id, ({type_params=[]} as td), rs)
when List.mem (Ident.name id) nl ->
let ty = List.assoc (Ident.name id) ntl in
Tsig_type (id, {td with type_manifest = Some ty}, rs)
| item -> item)
sg in
Tmty_signature sg'
| _ ->
if nl = [] then Tmty_ident p
else raise(Error(loc, Signature_expected))
with Not_found ->
raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
let wrap_constraint env arg mty =
let coercion =
try
Includemod.modtypes env arg.mod_type mty
with Includemod.Error msg ->
raise(Error(arg.mod_loc, Not_included msg)) in
{ mod_desc = Tmod_constraint(arg, mty, coercion);
mod_type = mty;
mod_env = env;
mod_loc = arg.mod_loc }
(* Type a module value expression *)
let rec type_module sttn funct_body anchor env smod =
@ -691,23 +727,35 @@ let rec type_module sttn funct_body anchor env smod =
| Pmod_constraint(sarg, smty) ->
let arg = type_module true funct_body anchor env sarg in
let mty = transl_modtype env smty in
let coercion =
try
Includemod.modtypes env arg.mod_type mty
with Includemod.Error msg ->
raise(Error(sarg.pmod_loc, Not_included msg)) in
rm { mod_desc = Tmod_constraint(arg, mty, coercion);
mod_type = mty;
mod_env = env;
mod_loc = smod.pmod_loc }
rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc}
| Pmod_unpack (sexp, (p, l)) ->
| Pmod_unpack sexp ->
if funct_body then
raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
let l, mty = Typetexp.create_package_mty smod.pmod_loc env (p, l) in
let mty = transl_modtype env mty in
let exp = Typecore.type_expect env sexp
(Typecore.create_package_type smod.pmod_loc env (p, l)) in
if !Clflags.principal then Ctype.begin_def ();
let exp = Typecore.type_exp env sexp in
if !Clflags.principal then begin
Ctype.end_def ();
Ctype.generalize_structure exp.exp_type
end;
let mty =
match Ctype.expand_head env exp.exp_type with
{desc = Tpackage (p, nl, tl)} ->
if List.exists (fun t -> Ctype.free_variables t <> []) tl then
raise (Error (smod.pmod_loc,
Incomplete_packed_module exp.exp_type));
if !Clflags.principal &&
not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
then
Location.prerr_warning smod.pmod_loc
(Warnings.Not_principal "this module unpacking");
modtype_of_package env smod.pmod_loc p nl tl
| {desc = Tvar} ->
raise (Typecore.Error
(smod.pmod_loc, Typecore.Cannot_infer_signature))
| _ ->
raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
in
rm { mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
mod_env = env;
@ -953,12 +1001,34 @@ let type_module_type_of env smod =
raise(Error(smod.pmod_loc, Non_generalizable_module mty));
mty
(* For Typecore *)
let rec get_manifest_types = function
[] -> []
| Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem ->
(Ident.name id, ty) :: get_manifest_types rem
| _ :: rem -> get_manifest_types rem
let type_package env m p nl tl =
let modl = type_module env m in
if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
let msig = extract_sig env modl.mod_loc modl.mod_type in
let mtypes = get_manifest_types msig in
let tl' =
List.map2
(fun name ty -> try List.assoc name mtypes with Not_found -> ty)
nl tl
in
let mty = modtype_of_package env modl.mod_loc p nl tl' in
(wrap_constraint env modl mty, tl')
(* Fill in the forward declarations *)
let () =
Typecore.type_module := type_module;
Typetexp.transl_modtype_longident := transl_modtype_longident;
Typetexp.transl_modtype := transl_modtype;
Typecore.type_open := type_open;
Typecore.type_package := type_package;
type_module_type_of_fwd := type_module_type_of
(* Typecheck an implementation file *)
@ -1106,3 +1176,11 @@ let report_error ppf = function
| With_need_typeconstr ->
fprintf ppf
"Only type constructors with identical parameters can be substituted."
| Not_a_packed_module ty ->
fprintf ppf
"This expression is not a packed module. It has type@ %a"
type_expr ty
| Incomplete_packed_module ty ->
fprintf ppf
"The type of this packed module contains variables:@ %a"
type_expr ty

2
typing/typemod.mli
View File

@ -51,6 +51,8 @@ type error =
| Interface_not_compiled of string
| Not_allowed_in_functor_body
| With_need_typeconstr
| Not_a_packed_module of type_expr
| Incomplete_packed_module of type_expr
exception Error of Location.t * error

5
typing/unused_var.ml
View File

@ -76,6 +76,7 @@ let rec get_vars ((vacc, asacc) as acc) p =
| Ppat_lazy p -> get_vars acc p
| Ppat_constraint (pp, _) -> get_vars acc pp
| Ppat_type _ -> acc
| Ppat_unpack _ -> acc
and get_vars_option acc po =
match po with
@ -174,7 +175,7 @@ and expression ppf tbl e =
| Pexp_poly (e, _) -> expression ppf tbl e;
| Pexp_object cs -> class_structure ppf tbl cs;
| Pexp_newtype (_, e) -> expression ppf tbl e
| Pexp_pack (me, _) -> module_expr ppf tbl me
| Pexp_pack me -> module_expr ppf tbl me
| Pexp_open (_, e) -> expression ppf tbl e
and expression_option ppf tbl eo =
@ -224,7 +225,7 @@ and module_expr ppf tbl me =
module_expr ppf tbl me1;
module_expr ppf tbl me2;
| Pmod_constraint (me, _) -> module_expr ppf tbl me
| Pmod_unpack (e, _) -> expression ppf tbl e
| Pmod_unpack (e) -> expression ppf tbl e
and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr