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

Merge olabl branch 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2651 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 1999-11-30 16:07:38 +00:00
parent ca0b21c5ad
commit 296fc05470
110 changed files with 4507 additions and 841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
INSTALL
View File

@ -69,6 +69,18 @@ The "configure" script accepts the following options:
It will *not* work under Digital Unix 3.2 or earlier, SunOS 4,
HPUX, AIX, nor Linux without LinuxThreads.
-tkdefs <cpp flags> (default: none)
-tklibs <flags and libraries> (default: determined automatically)
These options specify where to find the Tcl/Tk libraries for
LablTk. "-tkdefs" helps to find the headers, and "-tklibs"
the C libraries. "-tklibs" may contain either only -L/path flags,
in which case the library names are determined automatically,
or the actual libraries, which are used as given.
Example: for a Japanese tcl/tk whose headers are in specific
directories and libraries in /usr/local/lib, you can use
./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp"
-tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp"
Examples:
./configure -prefix /usr/bin
./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl

12
Makefile
View File

@ -87,13 +87,14 @@ TOPLEVEL=driver/errors.cmo driver/compile.cmo \
toplevel/printval.cmo toplevel/toploop.cmo \
toplevel/trace.cmo toplevel/topdirs.cmo
TOPLEVELLIB=toplevel/toplevellib.cma
TOPLEVELMAIN=toplevel/topmain.cmo
COMPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(DRIVER)
TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL)
TOPOBJS=$(TOPLIB) $(TOPLEVELMAIN)
TOPOBJS=toplevel/toplevellib.cma $(TOPLEVELMAIN)
OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
@ -151,6 +152,8 @@ coldstart:
cd stdlib; cp $(LIBFILES) ../boot
if test -f boot/libcamlrun.a; then :; else \
ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
if test -d boot/caml; then :; else \
ln -s ../byterun boot/caml; fi
# Save the current bootstrap compiler
MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
@ -208,7 +211,7 @@ install:
cd stdlib; $(MAKE) install
cp lex/ocamllex $(BINDIR)/ocamllex
cp yacc/ocamlyacc $(BINDIR)/ocamlyacc
$(CAMLC) -a -o $(LIBDIR)/toplevellib.cma $(TOPLIB)
cp toplevel/toplevellib.cma $(LIBDIR)/toplevellib.cma
cp expunge $(LIBDIR)
cp toplevel/topmain.cmo $(LIBDIR)
cp toplevel/toploop.cmi toplevel/topdirs.cmi $(LIBDIR)
@ -252,8 +255,11 @@ ocaml: $(TOPOBJS) expunge
- $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES)
rm -f ocaml.tmp
toplevel/toplevellib.cma: $(TOPLIB)
$(CAMLC) -a -o $@ $(TOPLIB)
partialclean::
rm -f ocaml
rm -f ocaml toplevel/toplevellib.cma
# The configuration file

20
asmcomp/linearize.ml
View File

@ -126,7 +126,7 @@ let add_branch lbl n =
(* Current label for exit handler *)
let exit_label = ref 99
let exit_label = ref None
(* Linearize an instruction [i]: add it in front of the continuation [n] *)
@ -153,10 +153,15 @@ let rec linear i n =
| _, Iend, Lbranch lbl ->
copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
| Iexit, _, _ ->
copy_instr (Lcondbranch(test, !exit_label)) i (linear ifnot n1)
let n2 = linear ifnot n1 in
begin match !exit_label with None -> n2
| Some lbl -> copy_instr (Lcondbranch(test, lbl)) i n2
end
| _, Iexit, _ ->
copy_instr (Lcondbranch(invert_test test, !exit_label)) i
(linear ifso n1)
let n2 = linear ifso n1 in
begin match !exit_label with None -> n2
| Some lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i n2
end
| Iend, _, _ ->
let (lbl_end, n2) = get_label n1 in
copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2)
@ -202,12 +207,15 @@ let rec linear i n =
let (lbl_end, n1) = get_label(linear i.Mach.next n) in
let (lbl_handler, n2) = get_label(linear handler n1) in
let saved_exit_label = !exit_label in
exit_label := lbl_handler;
exit_label := Some lbl_handler;
let n3 = linear body (add_branch lbl_end n2) in
exit_label := saved_exit_label;
n3
| Iexit ->
add_branch !exit_label (linear i.Mach.next n)
let n1 = linear i.Mach.next n in
begin match !exit_label with None -> n1
| Some lbl -> add_branch lbl n1
end
| Itrywith(body, handler) ->
let (lbl_join, n1) = get_label (linear i.Mach.next n) in
let (lbl_body, n2) =

4
asmcomp/spill.ml
View File

@ -34,7 +34,7 @@ open Mach
(* Association of spill registers to registers *)
let spill_env = ref (Reg.Map.empty: Reg.t Reg.Map.t)
let spill_env = ref (Reg.Map.empty : Reg.t Reg.Map.t)
let spill_reg r =
try
@ -48,7 +48,7 @@ let spill_reg r =
(* Record the position of last use of registers *)
let use_date = ref (Reg.Map.empty: int Reg.Map.t)
let use_date = ref (Reg.Map.empty : int Reg.Map.t)
let current_date = ref 0
let record_use regv =

2
bytecomp/bytegen.ml
View File

@ -243,7 +243,7 @@ let rec comp_expr env exp sz cont =
Koffsetclosure(ofs) :: cont
with Not_found ->
Ident.print id; print_newline();
fatal_error "Bytegen.comp_expr: var"
fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
end
| Lconst cst ->
Kconst cst :: cont

270
bytecomp/matching.ml
View File

@ -22,8 +22,8 @@ open Types
open Typedtree
open Lambda
(* See Peyton-Jones, "The Implementation of functional programming
languages", chapter 5. *)
(* See Peyton-Jones, ``The Implementation of functional programming
languages'', chapter 5. *)
type pattern_matching =
{ mutable cases : (pattern list * lambda) list;
@ -132,6 +132,62 @@ let divide_constructor {cases = cl; args = al} =
([], {cases = cl; args = al})
in divide cl
(* Making a constructor description from a variant pattern *)
let map_variant_matching row pm =
let row = Btype.row_repr row in
let consts = ref 0 and nonconsts = ref 0 in
if row.row_closed then
List.iter
(fun (_, f) ->
match Btype.row_field_repr f with
Rabsent | Reither(true, _::_, _) -> ()
| Reither(true, _, _) | Rpresent None -> incr consts
| Reither _ | Rpresent _ -> incr nonconsts)
row.row_fields
else (consts := 100000; nonconsts := 100000);
flush stderr;
let const_cstr =
{ cstr_res = Ctype.newty (Tvariant row);
cstr_args = [];
cstr_arity = 0;
cstr_tag = Cstr_block 0;
cstr_consts = !consts;
cstr_nonconsts = if !nonconsts = 0 then 0 else 1 }
and nonconst_cstr =
{ cstr_res = Predef.type_int;
cstr_args = [];
cstr_arity = 0;
cstr_tag = Cstr_block 0;
cstr_consts = !nonconsts;
cstr_nonconsts = 0 }
in
let pat_variant pat =
match pat.pat_desc with Tpat_variant (lab, pato, _) ->
if Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
then raise Not_found;
let tag = Cstr_constant (Btype.hash_variant lab) in
{ pat with pat_desc =
match pato with
None -> Tpat_construct({const_cstr with cstr_tag = tag}, [])
| Some pat' -> Tpat_construct
({ const_cstr with cstr_arity = 2 },
[{ pat with pat_desc =
Tpat_construct ({nonconst_cstr with cstr_tag = tag}, []);
pat_type = Predef.type_int };
pat'])
}
| _ -> pat
in
{ args = pm.args;
cases =
List.fold_right
(fun (patl, lam) l ->
try (List.map pat_variant patl, lam) :: l with Not_found -> l)
pm.cases [] },
const_cstr
(* Matching against a variable *)
let divide_var {cases = cl; args = al} =
@ -250,13 +306,35 @@ let combine_var (lambda1, total1) (lambda2, total2) =
else if lambda2 = Lstaticfail then (lambda1, total1)
else (Lcatch(lambda1, lambda2), total2)
let make_test_sequence tst arg const_lambda_list =
List.fold_right
(fun (c, act) rem ->
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
const_lambda_list Lstaticfail
let rec cut n l =
if n = 0 then [],l
else match l with
[] -> raise (Invalid_argument "cut")
| a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
let make_switch_or_test_sequence arg const_lambda_list int_lambda_list =
let make_test_sequence check tst lt_tst arg const_lambda_list =
let rec make_test_sequence const_lambda_list =
if List.length const_lambda_list >= 4 & lt_tst <> Praise then
split_sequence const_lambda_list
else
List.fold_right
(fun (c, act) rem ->
if rem = Lstaticfail && not check then act else
Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
const_lambda_list
Lstaticfail
and split_sequence const_lambda_list =
let list1, list2 =
cut (List.length const_lambda_list / 2) const_lambda_list in
Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
make_test_sequence list1, make_test_sequence list2)
in make_test_sequence
(Sort.list (fun (c1,_) (c2,_) -> c1 < c2) const_lambda_list)
let make_switch_or_test_sequence check arg const_lambda_list int_lambda_list =
if const_lambda_list = [] then
if check then Lstaticfail else lambda_unit
else
let min_key =
List.fold_right (fun (k, l) m -> min k m) int_lambda_list max_int in
let max_key =
@ -266,7 +344,8 @@ let make_switch_or_test_sequence arg const_lambda_list int_lambda_list =
if List.length int_lambda_list <= 1 + max_key / 4 - min_key / 4 then
(* Sparse matching -- use a sequence of tests
(4 bytecode instructions per test) *)
make_test_sequence (Pintcomp Ceq) arg const_lambda_list
make_test_sequence check (Pintcomp Ceq) (Pintcomp Clt)
arg const_lambda_list
else begin
(* Dense matching -- use a jump table
(2 bytecode instructions + 1 word per entry in the table) *)
@ -277,7 +356,7 @@ let make_switch_or_test_sequence arg const_lambda_list int_lambda_list =
if min_key = 0 then arg else Lprim(Poffsetint(-min_key), [arg]) in
Lswitch(offsetarg,
{sw_numconsts = numcases; sw_consts = cases;
sw_numblocks = 0; sw_blocks = []; sw_checked = true})
sw_numblocks = 0; sw_blocks = []; sw_checked = check})
end
let make_bitvect_check arg int_lambda_list =
@ -301,7 +380,7 @@ let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
let int_lambda_list =
List.map (function Const_int n, l -> n,l | _ -> assert false)
const_lambda_list in
make_switch_or_test_sequence arg const_lambda_list int_lambda_list
make_switch_or_test_sequence true arg const_lambda_list int_lambda_list
| Const_char _ ->
let int_lambda_list =
List.map (function Const_char c, l -> (Char.code c, l)
@ -310,14 +389,17 @@ let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
if List.for_all (fun (c, l) -> l = lambda_unit) const_lambda_list then
make_bitvect_check arg int_lambda_list
else
make_switch_or_test_sequence arg const_lambda_list int_lambda_list
make_switch_or_test_sequence true arg
const_lambda_list int_lambda_list
| Const_string _ ->
make_test_sequence prim_string_equal arg const_lambda_list
make_test_sequence true prim_string_equal Praise arg const_lambda_list
| Const_float _ ->
make_test_sequence (Pfloatcomp Ceq) arg const_lambda_list
make_test_sequence true (Pfloatcomp Ceq) (Pfloatcomp Clt)
arg const_lambda_list
in (Lcatch(lambda1, lambda2), total2)
let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
let combine_constructor arg cstr partial
(tag_lambda_list, total1) (lambda2, total2) =
if cstr.cstr_consts < 0 then begin
(* Special cases for exceptions *)
let lambda1 =
@ -341,31 +423,64 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
Cstr_constant n -> ((n, act) :: consts, nonconsts)
| Cstr_block n -> (consts, (n, act) :: nonconsts)
| _ -> assert false in
let (consts, nonconsts) = split_cases tag_lambda_list in
let (consts, nonconsts) = split_cases tag_lambda_list
and total = total1 &
(partial = Total or
List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts) in
let mkifthenelse arg act2 n act1 =
if n = 0 then Lifthenelse(arg, act2, act1) else
Lifthenelse
(Lprim (Pandint, [arg; Lconst (Const_pointer 0)]), act2, act1) in
let lambda1 =
if total &
List.for_all (fun (_, act) -> act = lambda_unit) tag_lambda_list
then
lambda_unit
else
match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
(1, 0, [0, act], []) -> act
(_, _, [n, act], []) when total -> act
| (_, _, [], [n, act]) when total -> act
| (_, _, [n, act1], [m, act2]) when total ->
mkifthenelse arg act2 n act1
| (1, 0, [n, act], []) -> act
| (0, 1, [], [0, act]) -> act
| (1, 1, [0, act1], [0, act2]) ->
Lifthenelse(arg, act2, act1)
| (1, 1, [0, act1], []) ->
Lifthenelse(arg, Lstaticfail, act1)
| (1, 1, [], [0, act2]) ->
Lifthenelse(arg, act2, Lstaticfail)
| (1, 1, [n, act1], [0, act2]) ->
mkifthenelse arg act2 n act1
| (1, 1, [n, act1], []) ->
mkifthenelse arg Lstaticfail n act1
| (n, 1, [], [0, act2]) ->
mkifthenelse arg act2 1 Lstaticfail
| (_, _, _, _) ->
Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
sw_consts = consts;
sw_numblocks = cstr.cstr_nonconsts;
sw_blocks = nonconsts;
sw_checked = false}) in
if total1
&& List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
then (lambda1, true)
if cstr.cstr_nonconsts > 1
|| List.for_all (fun (n,_) -> n < cstr.cstr_consts & n >= 0) consts
&& List.for_all (fun (n,_) -> n < cstr.cstr_nonconsts & n >= 0)
nonconsts
&& List.length consts > 1 + cstr.cstr_consts / 4
then
Lswitch(arg, {sw_numconsts = cstr.cstr_consts;
sw_consts = consts;
sw_numblocks = cstr.cstr_nonconsts;
sw_blocks = nonconsts;
sw_checked = false})
else
let cases = List.map (fun (n, act) -> Const_int n, act) consts in
if cstr.cstr_nonconsts = 0 then
make_switch_or_test_sequence (not total) arg cases consts
else
let act =
match nonconsts with [_, act] -> act | _ -> Lstaticfail in
mkifthenelse arg act 1
(make_switch_or_test_sequence (not total) arg cases consts)
in
if total then (lambda1, true)
else (Lcatch(lambda1, lambda2), total2)
end
let combine_orpat (lambda1, total1) (lambda2, total2) (lambda3, total3) =
(Lcatch(Lsequence(lambda1, lambda2), lambda3), total3)
if total1 & total2 then
(Lsequence(lambda1, lambda2), true)
else
(Lcatch(Lsequence(lambda1, lambda2), lambda3), total3)
let combine_array kind arg (len_lambda_list, total1) (lambda2, total2) =
let lambda1 =
@ -412,13 +527,13 @@ let rec event_branch repr lam =
Output: a lambda term, a "total" flag (true if we're sure that the
matching covers all cases; this is an approximation). *)
let rec compile_match repr m =
let rec compile_match repr partial m =
let rec compile_list = function
let rec compile_list partial = function
[] -> ([], true)
| (key, pm) :: rem ->
let (lambda1, total1) = compile_match repr pm in
let (list2, total2) = compile_list rem in
let (lambda1, total1) = compile_match repr partial pm in
let (list2, total2) = compile_list partial rem in
((key, lambda1) :: list2, total1 & total2) in
match m with
@ -427,8 +542,7 @@ let rec compile_match repr m =
| { cases = ([], action) :: rem; args = argl } ->
if is_guarded action then begin
let (lambda, total) =
compile_match None { cases = rem; args = argl }
in
compile_match None partial { cases = rem; args = argl } in
(Lcatch(event_branch repr action, lambda), total)
end else
(event_branch repr action, true)
@ -444,35 +558,64 @@ let rec compile_match repr m =
begin match pat.pat_desc with
Tpat_any ->
let (vars, others) = divide_var pm in
combine_var (compile_match repr vars)
(compile_match repr others)
let partial' =
if others.cases = [] then partial else Partial in
combine_var (compile_match repr partial' vars)
(compile_match repr partial others)
| Tpat_constant cst ->
let (constants, others) = divide_constant pm in
let partial' =
if others.cases = [] then partial else Partial in
combine_constant newarg cst
(compile_list constants) (compile_match repr others)
(compile_list partial' constants)
(compile_match repr partial others)
| Tpat_tuple patl ->
let (tuples, others) = divide_tuple (List.length patl) pm in
combine_var (compile_match repr tuples)
(compile_match repr others)
let partial' =
if others.cases = [] then partial else Partial in
combine_var (compile_match repr partial' tuples)
(compile_match repr partial others)
| Tpat_construct(cstr, patl) ->
let (constrs, others) = divide_constructor pm in
combine_constructor newarg cstr
(compile_list constrs) (compile_match repr others)
let partial' =
if others.cases = [] then partial else Partial in
combine_constructor newarg cstr partial'
(compile_list partial' constrs)
(compile_match repr partial others)
| Tpat_variant(lab, _, row) ->
let pm, cstr = map_variant_matching row pm in
let (constrs, others) = divide_constructor pm in
let partial' =
if others.cases = [] then partial else Partial in
combine_constructor newarg cstr partial'
(compile_list partial' constrs)
(compile_match repr partial others)
| Tpat_record((lbl, _) :: _) ->
let (records, others) = divide_record lbl.lbl_all pm in
combine_var (compile_match repr records)
(compile_match repr others)
let partial' =
if others.cases = [] then partial else Partial in
combine_var (compile_match repr partial' records)
(compile_match repr partial others)
| Tpat_array(patl) ->
let kind = Typeopt.array_pattern_kind pat in
let (arrays, others) = divide_array kind pm in
combine_array kind newarg (compile_list arrays)
(compile_match repr others)
combine_array kind newarg
(compile_list Partial arrays)
(compile_match repr partial others)
| Tpat_or(pat1, pat2) ->
(* Avoid duplicating the code of the action *)
let (or_match, remainder_line, others) = divide_orpat pm in
combine_orpat (compile_match None or_match)
(compile_match repr remainder_line)
(compile_match repr others)
let partial' =
if others.cases = [] then partial else Partial in
if partial' = Total then
or_match.cases <- [[{ pat_desc = Tpat_any;
pat_loc = pat.pat_loc;
pat_type = pat.pat_type;
pat_env = pat.pat_env }],
lambda_unit];
combine_orpat (compile_match None Partial or_match)
(compile_match repr partial' remainder_line)
(compile_match repr partial others)
| _ ->
fatal_error "Matching.compile_match1"
end
@ -482,11 +625,11 @@ let rec compile_match repr m =
(* The entry points *)
let compile_matching repr handler_fun arg pat_act_list =
let compile_matching repr handler_fun arg pat_act_list partial =
let pm =
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
args = [arg, Strict] } in
let (lambda, total) = compile_match repr pm in
let (lambda, total) = compile_match repr partial pm in
if total then lambda else Lcatch(lambda, handler_fun())
let partial_function loc () =
@ -497,14 +640,15 @@ let partial_function loc () =
Const_base(Const_int loc.loc_start);
Const_base(Const_int loc.loc_end)]))])])
let for_function loc repr param pat_act_list =
compile_matching repr (partial_function loc) param pat_act_list
let for_function loc repr param pat_act_list partial =
compile_matching repr (partial_function loc) param pat_act_list partial
let for_trywith param pat_act_list =
compile_matching None (fun () -> Lprim(Praise, [param])) param pat_act_list
compile_matching None (fun () -> Lprim(Praise, [param]))
param pat_act_list Partial
let for_let loc param pat body =
compile_matching None (partial_function loc) param [pat, body]
compile_matching None (partial_function loc) param [pat, body] Partial
(* Handling of tupled functions and matches *)
@ -521,14 +665,14 @@ let flatten_cases size cases =
| _ -> assert false)
cases
let for_tupled_function loc paraml pats_act_list =
let for_tupled_function loc paraml pats_act_list partial =
let pm =
{ cases = pats_act_list;
args = List.map (fun id -> (Lvar id, Strict)) paraml } in
let (lambda, total) = compile_match None pm in
let (lambda, total) = compile_match None partial pm in
if total then lambda else Lcatch(lambda, partial_function loc ())
let for_multiple_match loc paraml pat_act_list =
let for_multiple_match loc paraml pat_act_list partial =
let pm1 =
{ cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] } in
@ -539,10 +683,10 @@ let for_multiple_match loc paraml pat_act_list =
let pm3 =
{ cases = flatten_cases (List.length paraml) pm2.cases;
args = List.map (fun id -> (Lvar id, Alias)) idl } in
let (lambda, total) = compile_match None pm3 in
let (lambda, total) = compile_match None partial pm3 in
let lambda2 =
if total then lambda else Lcatch(lambda, partial_function loc ()) in
List.fold_right2 (bind Strict) idl paraml lambda2
with Cannot_flatten ->
let (lambda, total) = compile_match None pm2 in
let (lambda, total) = compile_match None partial pm2 in
if total then lambda else Lcatch(lambda, partial_function loc ())

8
bytecomp/matching.mli
View File

@ -19,15 +19,17 @@ open Lambda
val for_function:
Location.t -> int ref option -> lambda -> (pattern * lambda) list ->
lambda
partial -> lambda
val for_trywith:
lambda -> (pattern * lambda) list -> lambda
val for_let:
Location.t -> lambda -> pattern -> lambda -> lambda
val for_multiple_match:
Location.t -> lambda list -> (pattern * lambda) list -> lambda
Location.t -> lambda list -> (pattern * lambda) list -> partial ->
lambda
val for_tupled_function:
Location.t -> Ident.t list -> (pattern list * lambda) list -> lambda
Location.t -> Ident.t list -> (pattern list * lambda) list ->
partial -> lambda
exception Cannot_flatten

10
bytecomp/translclass.ml
View File

@ -136,7 +136,7 @@ let rec build_object_init cl_table obj params inh_init cl =
(fun (id, expr) rem ->
lsequence (Lifused (id, set_inst_var obj id expr)) rem)
params obj_init))
| Tclass_fun (pat, vals, cl) ->
| Tclass_fun (pat, vals, cl, partial) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init cl
in
@ -145,17 +145,17 @@ let rec build_object_init cl_table obj params inh_init cl =
let param = name_pattern "param" [pat, ()] in
Lfunction (Curried, param::params,
Matching.for_function
pat.pat_loc None (Lvar param) [pat, rem])
pat.pat_loc None (Lvar param) [pat, rem] partial)
in
begin match obj_init with
Lfunction (Curried, params, rem) -> build params rem
| rem -> build [] rem
end)
| Tclass_apply (cl, exprs) ->
| Tclass_apply (cl, oexprs) ->
let (inh_init, obj_init) =
build_object_init cl_table obj params inh_init cl
in
(inh_init, lapply obj_init (List.map transl_exp exprs))
(inh_init, transl_apply obj_init oexprs)
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init cl
@ -235,7 +235,7 @@ let rec build_class_init cla pub_meths cstr inh_init cl_init cl =
(inh_init, cl_init)
in
(inh_init, bind_methods cla pub_meths str.cl_meths cl_init)
| Tclass_fun (pat, vals, cl) ->
| Tclass_fun (pat, vals, cl, _) ->
let (inh_init, cl_init) =
build_class_init cla pub_meths cstr inh_init cl_init cl
in

112
bytecomp/translcore.ml
View File

@ -310,6 +310,7 @@ let event_function exp lam =
else
lam None
(* Translation of expressions *)
let rec transl_exp e =
@ -324,36 +325,28 @@ let rec transl_exp e =
Lconst(Const_base cst)
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
| Texp_function pat_expr_list ->
| Texp_function (pat_expr_list, partial) ->
let ((kind, params), body) =
event_function e
(function repr ->
transl_function e.exp_loc !Clflags.native_code repr pat_expr_list)
transl_function e.exp_loc !Clflags.native_code repr [] partial
pat_expr_list)
in
Lfunction(kind, params, body)
| Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
when List.length args = p.prim_arity ->
when List.length args = p.prim_arity && List.for_all ((<>) None) args ->
let args = List.map (function Some x -> x | None -> assert false) args in
let prim = transl_prim p args in
let lam = Lprim(prim, transl_list args) in
begin match prim with Pccall _ -> event_after e lam | _ -> lam end
| Texp_apply(funct, args) ->
let lam =
match transl_exp funct with
Lsend(lmet, lobj, largs) ->
Lsend(lmet, lobj, largs @ transl_list args)
| Levent(Lsend(lmet, lobj, largs), _) ->
Lsend(lmet, lobj, largs @ transl_list args)
| Lapply(lexp, largs) ->
Lapply(lexp, largs @ transl_list args)
| lexp ->
Lapply(lexp, transl_list args) in
event_after e lam
| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list) ->
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs)
| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
Matching.for_multiple_match e.exp_loc
(transl_list argl) (transl_cases pat_expr_list)
| Texp_match(arg, pat_expr_list) ->
(transl_list argl) (transl_cases pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
Matching.for_function e.exp_loc None
(transl_exp arg) (transl_cases pat_expr_list)
(transl_exp arg) (transl_cases pat_expr_list) partial
| Texp_try(body, pat_expr_list) ->
let id = name_pattern "exn" pat_expr_list in
Ltrywith(transl_exp body, id,
@ -379,6 +372,17 @@ let rec transl_exp e =
| Cstr_exception path ->
Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
end
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
begin match arg with
None -> Lconst(Const_pointer tag)
| Some arg ->
let lam = transl_exp arg in
try
Lconst(Const_block(0,[Const_pointer tag; extract_constant lam]))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable), [Lconst(Const_pointer tag); lam])
end
| Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
| Texp_field(arg, lbl) ->
@ -472,13 +476,69 @@ and transl_cases pat_expr_list =
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
and transl_function loc untuplify_fn repr pat_expr_list =
and transl_apply lam sargs =
let lapply funct args =
match funct with
Lsend(lmet, lobj, largs) ->
Lsend(lmet, lobj, largs @ args)
| Levent(Lsend(lmet, lobj, largs), _) ->
Lsend(lmet, lobj, largs @ args)
| Lapply(lexp, largs) ->
Lapply(lexp, largs @ args)
| lexp ->
Lapply(lexp, args)
in
let rec build_apply lam args = function
None :: l ->
let lam =
if args = [] then lam else lapply lam (List.rev args) in
let (var, handle) =
match lam with
Lvar _ -> (None, lam)
| _ ->
let id = Ident.create "app" in (Some id, Lvar id)
and id_arg = Ident.create "arg" in
let body =
match build_apply handle [Lvar id_arg] l with
Lfunction(Curried, ids, lam) ->
Lfunction(Curried, id_arg::ids, lam)
| Levent(Lfunction(Curried, ids, lam), _) ->
Lfunction(Curried, id_arg::ids, lam)
| lam ->
Lfunction(Curried, [id_arg], lam)
in
begin match var with
None -> body
| Some id -> Llet(Strict, id, lam, body)
end
| Some arg :: l ->
build_apply lam (transl_exp arg :: args) l
| [] ->
lapply lam (List.rev args)
in
build_apply lam [] sargs
and transl_function loc untuplify_fn repr bindings partial pat_expr_list =
match pat_expr_list with
[pat, ({exp_desc = Texp_function pl} as exp)] ->
[pat, ({exp_desc = Texp_function(pl,partial')} as exp)] ->
let param = name_pattern "param" pat_expr_list in
let ((_, params), body) = transl_function exp.exp_loc false repr pl in
let ((_, params), body) =
transl_function exp.exp_loc false repr bindings partial' pl in
((Curried, param :: params),
Matching.for_function loc None (Lvar param) [pat, body])
Matching.for_function loc None (Lvar param) [pat, body] partial)
| [({pat_desc = Tpat_var id} as pat),
({exp_desc = Texp_let(Nonrecursive, cases,
({exp_desc = Texp_function _} as e2))} as e1)]
when Ident.name id = "*opt*" ->
transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
| [pat, exp] when bindings <> [] ->
let exp =
List.fold_left
(fun exp cases ->
{exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
exp bindings
in
transl_function loc untuplify_fn repr [] partial [pat, exp]
| ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
begin try
let size = List.length pl in
@ -489,18 +549,18 @@ and transl_function loc untuplify_fn repr pat_expr_list =
let params = List.map (fun p -> Ident.create "param") pl in
((Tupled, params),
Matching.for_tupled_function loc params
(transl_tupled_cases pats_expr_list))
(transl_tupled_cases pats_expr_list) partial)
with Matching.Cannot_flatten ->
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list))
(transl_cases pat_expr_list) partial)
end
| _ ->
let param = name_pattern "param" pat_expr_list in
((Curried, [param]),
Matching.for_function loc repr (Lvar param)
(transl_cases pat_expr_list))
(transl_cases pat_expr_list) partial)
and transl_let rec_flag pat_expr_list body =
match rec_flag with

1
bytecomp/translcore.mli
View File

@ -23,6 +23,7 @@ open Lambda
val name_pattern: string -> (pattern * 'a) list -> Ident.t
val transl_exp: expression -> lambda
val transl_apply: lambda -> expression option list -> lambda
val transl_let:
rec_flag -> (pattern * expression) list -> lambda -> lambda
val transl_primitive: Primitive.description -> lambda

10
config/auto-aux/hasgot
View File

@ -2,6 +2,7 @@
opts=""
libs="$cclibs"
args=$*
rm -f hasgot.c
while : ; do
case "$1" in
@ -12,7 +13,14 @@ while : ; do
esac
shift
done
(echo "main() {"
for f in $*; do echo " $f();"; done
echo "}") >> hasgot.c
exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
if test "$verbose" = yes; then
echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2
exec $cc $opts -o tst hasgot.c $libs > /dev/null
else
exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
fi

3
config/auto-aux/runtest
View File

@ -1,3 +1,6 @@
#!/bin/sh
if test "$verbose" = yes; then
echo "runtest: $cc -o tst $: $cclibs" >&2
fi
$cc -o tst $* $cclibs || exit 100
exec ./tst

7
config/auto-aux/tclversion.c Normal file
View File

@ -0,0 +1,7 @@
#include <stdio.h>
#include <tcl.h>
main ()
{
puts(TCL_VERSION);
}

116
configure vendored
View File

@ -25,7 +25,10 @@ cclibs=''
mathlib='-lm'
x11_include_dir=''
x11_lib_dir=''
tk_defs=''
tk_libs=''
posix_threads=no
verbose=no
# Parse command-line arguments
@ -54,6 +57,12 @@ while : ; do
x11_lib_dir=$2; shift;;
-with-pthread*|--with-pthread*)
posix_threads=yes;;
-tkdefs*|--tkdefs*)
tk_defs=$2; shift;;
-tklibs*|--tklibs*)
tk_libs=$2; shift;;
-verbose|--verbose)
verbose=yes; shift;;
*) echo "Unknown option \"$1\"." 1>&2; exit 2;;
esac
shift
@ -199,7 +208,7 @@ esac
# Configure compiler to use in further tests
cc="$bytecc $bytecclinkopts"
export cc cclibs
export cc cclibs verbose
# Check C compiler
@ -632,6 +641,11 @@ if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then
echo "#define HAS_LOCALE" >> s.h
fi
if sh ./hasgot -ldl dlopen; then
echo "dlopen() found."
dllib=-ldl
fi
# Determine if the debugger is supported
if test "$has_sockets" = "yes"; then
@ -713,7 +727,12 @@ do
if test -f $dir/libX11.a || \
test -f $dir/libX11.so || \
test -f $dir/libX11.sa; then
x11_link="-cclib -L$dir -cclib -lX11"
if test $dir = /usr/lib; then
x11_link="-cclib -lX11"
else
x11_link="-cclib -L$dir -cclib -lX11"
x11_libs="-L$dir"
fi
break
fi
done
@ -745,6 +764,90 @@ else
echo "NDBM not found, the \"dbm\" library will not be supported."
fi
# Look for tcl/tk
echo "Configuring LablTk..."
if test "$x11_include" = "not found" || test "$x11_link" = "not found"
then
echo "X11 not found."
has_tk=false
else
has_tk=true
tcl_version=''
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
if test -z "$tcl_version" && test -z "$tk_defs"; then
tk_defs=-I/usr/local/include
tcl_version=`sh ./runtest $tk_defs tclversion.c 2> /dev/null`
fi
if test -n "$tcl_version"; then
echo "tcl.h version $tcl_version found."
case $tcl_version in
7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
*) echo "This version is not known."; has_tk=false ;;
esac
else
echo "tcl.h not found."
has_tk=false
fi
fi
if test $has_tk = true; then
if sh ./hasgot $x11_include $tk_defs -i tk.h; then
echo "tk.h found."
else
echo "tk.h not found."
has_tk=false
fi
fi
tkauxlibs="$mathlib $dllib"
tcllib=''
tklib=''
if test $has_tk = true; then
if sh ./hasgot $tk_libs $tkauxlibs Tcl_DoOneEvent
then tk_libs="$tk_libs $dllib"
elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent
then
tk_libs="$tk_libs -ltcl$tclmaj.$tclmin -ltk$tkmaj.$tkmin $dllib"
elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent
then
tk_libs="$tk_libs -ltcl$tclmaj$tclmin -ltk$tkmaj$tkmin $dllib"
elif test -z "$tk_libs" && tk_libs=-L/usr/local/lib && \
sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent
then
tk_libs="$tk_libs -ltcl$tclmaj.$tclmin -ltk$tkmaj.$tkmin $dllib"
elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent
then
tk_libs="$tk_libs -ltcl$tclmaj$tclmin -ltk$tkmaj$tkmin $dllib"
# elif sh ./hasgot $tk_libs -ltcl $tkauxlibs Tcl_DoOneEvent; then
# tk_libs="$tk_libs -ltcl -ltk"
else
echo "Tcl library not found."
has_tk=false
fi
fi
if test $has_tk = true; then
if sh ./hasgot $tk_libs $x11_libs -lX11 $tkauxlibs Tk_SetGrid; then
echo "Tcl/Tk libraries found."
else
echo "Tcl library found."
echo "Tk library not found."
has_tk=false
fi
fi
if test $has_tk = true; then
echo "TK_DEFS=$tk_defs" >> Makefile
echo "TK_LINK=$tk_libs" >> Makefile
otherlibraries="$otherlibraries labltk"
else
echo "Configuration failed, LablTk will not be built."
fi
# Finish generated files
cclibs="$cclibs $mathlib"
@ -766,6 +869,7 @@ echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile
echo "PROFILING=$profiling" >> Makefile
echo "CCLIBS=$cclibs" >> Makefile
echo "DYNLINKOPTS=$dllib" >> Makefile
echo "OTHERLIBRARIES=$otherlibraries" >> Makefile
echo "DEBUGGER=$debugger" >> Makefile
@ -830,3 +934,11 @@ echo " options for compiling .... $x11_include"
echo " options for linking ...... $x11_link"
fi
if test $has_tk = true; then
echo "The \"labltk\" library:"
echo " use tcl/tk version ....... $tcl_version"
echo " options for compiling .... $tk_defs"
echo " options for linking ...... $tk_libs"
else
echo "The \"labltk\" library: configuration failed"
fi

2
debugger/command_line.ml
View File

@ -549,7 +549,7 @@ let instr_break lexbuf =
begin try
let (v, ty) = Eval.expression !selected_event env expr in
match (Ctype.repr ty).desc with
Tarrow (_, _) ->
Tarrow _ ->
add_breakpoint_after_pc (Remote_value.closure_code v)
| _ ->
prerr_endline "Not a function.";

2
debugger/loadprinter.ml
View File

@ -101,7 +101,7 @@ let find_printer_type lid =
Ctype.begin_def();
let ty_arg = Ctype.newvar() in
Ctype.unify Env.empty
(Ctype.newty (Tarrow(ty_arg, Ctype.instance Predef.type_unit)))
(Ctype.newty (Tarrow("", ty_arg, Ctype.instance Predef.type_unit)))
(Ctype.instance desc.val_type);
Ctype.end_def();
Ctype.generalize ty_arg;

2
driver/errors.ml
View File

@ -29,6 +29,8 @@ let report_error exn =
Syntaxerr.report_error err
| Env.Error err ->
Env.report_error err
| Ctype.Tags(l, l') ->
printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value." l l'
| Typecore.Error(loc, err) ->
Location.print loc; Typecore.report_error err
| Typetexp.Error(loc, err) ->

2
driver/main.ml
View File

@ -57,6 +57,7 @@ let usage = "Usage: ocamlc <options> <files>\nOptions are:"
module Options = Main_args.Make_options (struct
let set r () = r := true
let unset r () = r := false
let _a = set make_archive
let _c = set compile_only
let _cc s = c_compiler := s
@ -72,6 +73,7 @@ module Options = Main_args.Make_options (struct
let _linkall = set link_everything
let _make_runtime () =
custom_runtime := true; make_runtime := true; link_everything := true
let _modern = unset classic
let _noassert = set noassert
let _o s = exec_name := s; archive_name := s; object_name := s
let _output_obj () = output_c_object := true; custom_runtime := true

2
driver/main_args.ml
View File

@ -28,6 +28,7 @@ module Make_options (F :
val _intf_suffix : string -> unit
val _linkall : unit -> unit
val _make_runtime : unit -> unit
val _modern : unit -> unit
val _noassert : unit -> unit
val _o : string -> unit
val _output_obj : unit -> unit
@ -67,6 +68,7 @@ struct
"<file> Suffix for interface files (default: .mli)";
"-intf_suffix", Arg.String F._intf_suffix,
"<file> (deprecated) same as -intf-suffix";
"-modern", Arg.Unit F._modern, " Use strict label syntax";
"-linkall", Arg.Unit F._linkall, " Link all modules, even unused ones";
"-make-runtime", Arg.Unit F._make_runtime,
" Build a runtime system with given C objects and libraries";

1
driver/main_args.mli
View File

@ -28,6 +28,7 @@ module Make_options (F :
val _intf_suffix : string -> unit
val _linkall : unit -> unit
val _make_runtime : unit -> unit
val _modern : unit -> unit
val _noassert : unit -> unit
val _o : string -> unit
val _output_obj : unit -> unit

1
driver/optmain.ml
View File

@ -83,6 +83,7 @@ let main () =
"<file> same as -intf-suffix";
"-linkall", Arg.Set link_everything,
" Link all modules, even unused ones";
"-modern", Arg.Clear classic, " Use strict label syntax";
"-noassert", Arg.Set noassert, " Don't compile assertion checks";
"-o", Arg.String(fun s -> exec_name := s;
archive_name := s;

2
lex/lexgen.ml
View File

@ -169,7 +169,7 @@ let split_trans_set trans_set =
module StateMap =
Map.Make(struct type t = TransSet.t let compare = TransSet.compare end)
let state_map = ref (StateMap.empty: int StateMap.t)
let state_map = ref (StateMap.empty : int StateMap.t)
let todo = (Stack.create() : (TransSet.t * int) Stack.t)
let next_state_num = ref 0

9
man/ocaml.m
View File

@ -7,6 +7,9 @@ ocaml \- The Objective Caml interactive toplevel
.SH SYNOPSIS
.B ocaml
[
.B \-modern
]
[
.B \-unsafe
]
[
@ -50,6 +53,12 @@ are searched after the current directory, in the order in which they
were given on the command line, but before the standard library
directory.
.TP
.B \-modern
Switch to the modern semantics for application. Arguments should be
explicitly labeled by labels appearing in types. Arguments with different
labels may commute freely.
.TP
.B \-unsafe
Turn bound checking off on array and string accesses (the v.(i)

9
man/ocamlc.m
View File

@ -19,6 +19,9 @@ ocamlc \- The Objective Caml bytecode compiler
.B \-custom
]
[
.B \-modern
]
[
.B \-unsafe
]
[
@ -227,6 +230,12 @@ option is given, specify the name of the library produced.
.B \-v
Print the version number of the compiler.
.TP
.B \-modern
Switch to the modern semantics for application. Arguments should be
explicitly labeled by labels appearing in types. Arguments with different
labels may commute freely.
.TP
.B \-unsafe
Turn bound checking off on array and string accesses (the

9
man/ocamlopt.m
View File

@ -19,6 +19,9 @@ ocamlopt \- The Objective Caml native-code compiler
.B \-compact
]
[
.B \-modern
]
[
.B \-unsafe
]
[
@ -216,6 +219,12 @@ is saved in the file
.B \-v
Print the version number of the compiler.
.TP
.B \-modern
Switch to the modern semantics for application. Arguments should be
explicitly labeled by labels appearing in types. Arguments with different
labels may commute freely.
.TP
.B \-unsafe
Turn bound checking off on array and string accesses (the v.(i) and

21
otherlibs/db/db.mli
View File

@ -47,7 +47,8 @@ type data = string
type t
(* Raw access *)
external dbopen : string -> open_flag list -> file_perm -> btree_flag list -> t
external dbopen :
string -> flags:open_flag list -> perm:file_perm -> btree_flag list -> t
= "caml_db_open"
(* [dbopen file flags mode] *)
@ -55,26 +56,26 @@ external dbopen : string -> open_flag list -> file_perm -> btree_flag list -> t
external close : t -> unit
= "caml_db_close"
external del : t -> key -> routine_flag list -> unit
external del : t -> key:key -> cmd:routine_flag list -> unit
= "caml_db_del"
(* raise Not_found if the key was not in the file *)
external get : t -> key -> routine_flag list -> data
external get : t -> key:key -> cmd:routine_flag list -> data
= "caml_db_get"
(* raise Not_found if the key was not in the file *)
external put : t -> key -> data -> routine_flag list -> unit
external put : t -> key:key -> data:data -> cmd:routine_flag list -> unit
= "caml_db_put"
external seq : t -> key -> routine_flag list -> (key * data)
external seq : t -> key:key -> cmd:routine_flag list -> (key * data)
= "caml_db_seq"
external sync : t -> unit
= "caml_db_sync"
val add : t -> key -> data -> unit
val find : t -> key -> data
val find_all : t -> key -> data list
val remove : t -> key -> unit
val iter : (string -> string -> unit) -> t -> unit
val add : t -> key:key -> data:data -> unit
val find : t -> key:key -> data
val find_all : t -> key:key -> data list
val remove : t -> key:key -> unit
val iter : fun:(key:string -> data:string -> unit) -> t -> unit

12
otherlibs/dbm/dbm.mli
View File

@ -24,7 +24,7 @@ type open_flag =
exception Dbm_error of string
(* Raised by the following functions when an error is encountered. *)
val opendbm : string -> open_flag list -> int -> t
val opendbm : string -> flags:open_flag list -> perm:int -> t
(* Open a descriptor on an NDBM database. The first argument is
the name of the database (without the [.dir] and [.pag] suffixes).
The second argument is a list of flags: [Dbm_rdonly] opens
@ -35,20 +35,20 @@ val opendbm : string -> open_flag list -> int -> t
files, if the database is created. *)
external close : t -> unit = "caml_dbm_close"
(* Close the given descriptor. *)
external find : t -> string -> string = "caml_dbm_fetch"
external find : t -> key:string -> string = "caml_dbm_fetch"
(* [find db key] returns the data associated with the given
[key] in the database opened for the descriptor [db].
Raise [Not_found] if the [key] has no associated data. *)
external add : t -> string -> string -> unit = "caml_dbm_insert"
external add : t -> key:string -> data:string -> unit = "caml_dbm_insert"
(* [add db key data] inserts the pair ([key], [data]) in
the database [db]. If the database already contains data
associated with [key], raise [Dbm_error "Entry already exists"]. *)
external replace : t -> string -> string -> unit = "caml_dbm_replace"
external replace : t -> key:string -> data:string -> unit = "caml_dbm_replace"
(* [replace db key data] inserts the pair ([key], [data]) in
the database [db]. If the database already contains data
associated with [key], that data is discarded and silently
replaced by the new [data]. *)
external remove : t -> string -> unit = "caml_dbm_delete"
external remove : t -> key:string -> unit = "caml_dbm_delete"
(* [remove db key data] removes the data associated with [key]
in [db]. If [key] has no associated data, raise
[Dbm_error "dbm_delete"]. *)
@ -58,7 +58,7 @@ external nextkey : t -> string = "caml_dbm_nextkey"
[firstkey db] returns the first key, and repeated calls
to [nextkey db] return the remaining keys. [Not_found] is raised
when all keys have been enumerated. *)
val iter : (string -> string -> 'a) -> t -> unit
val iter : fun:(key:string -> data:string -> 'a) -> t -> unit
(* [iter f db] applies [f] to each ([key], [data]) pair in
the database [db]. [f] receives [key] as first argument
and [data] as second argument. *)

2
otherlibs/dynlink/dynlink.mli
View File

@ -26,7 +26,7 @@ val loadfile : string -> unit
val loadfile_private : string -> unit
(* Same as [loadfile], except that the module loaded is not
made available to other modules dynamically loaded afterwards. *)
val add_interfaces : string list -> string list -> unit
val add_interfaces : units:string list -> paths:string list -> unit
(* [add_interfaces units path] grants dynamically-linked object
files access to the compilation units named in list [units].
The interfaces ([.cmi] files) for these units are searched in

26
otherlibs/graph/graphics.mli
View File

@ -86,16 +86,17 @@ external current_point : unit -> int * int = "gr_current_point"
external lineto : int -> int -> unit = "gr_lineto"
(* Draw a line with endpoints the current point and the given point,
and move the current point to the given point. *)
external draw_arc : int -> int -> int -> int -> int -> int -> unit
external draw_arc :
int -> int -> rx:int -> ry:int -> start:int -> stop:int -> unit
= "gr_draw_arc" "gr_draw_arc_nat"
(* [draw_arc x y rx ry a1 a2] draws an elliptical arc with center
[x,y], horizontal radius [rx], vertical radius [ry], from angle
[a1] to angle [a2] (in degrees). The current point is unchanged. *)
val draw_ellipse : int -> int -> int -> int -> unit
val draw_ellipse : int -> int -> rx:int -> ry:int -> unit
(* [draw_ellipse x y rx ry] draws an ellipse with center
[x,y], horizontal radius [rx] and vertical radius [ry].
The current point is unchanged. *)
val draw_circle : int -> int -> int -> unit
val draw_circle : int -> int -> r:int -> unit
(* [draw_circle x y r] draws a circle with center [x,y] and
radius [r]. The current point is unchanged. *)
external set_line_width : int -> unit = "gr_set_line_width"
@ -122,20 +123,21 @@ external text_size : string -> int * int = "gr_text_size"
(*** Filling *)
external fill_rect : int -> int -> int -> int -> unit = "gr_fill_rect"
external fill_rect : int -> int -> w:int -> h:int -> unit = "gr_fill_rect"
(* [fill_rect x y w h] fills the rectangle with lower left corner
at [x,y], width [w] and height [h], with the current color. *)
external fill_poly : (int * int) array -> unit = "gr_fill_poly"
(* Fill the given polygon with the current color. The array
contains the coordinates of the vertices of the polygon. *)
external fill_arc : int -> int -> int -> int -> int -> int -> unit
external fill_arc :
int -> int -> rx:int -> ry:int -> start:int -> stop:int -> unit
= "gr_fill_arc" "gr_fill_arc_nat"
(* Fill an elliptical pie slice with the current color. The
parameters are the same as for [draw_arc]. *)
val fill_ellipse : int -> int -> int -> int -> unit
val fill_ellipse : int -> int -> rx:int -> ry:int -> unit
(* Fill an ellipse with the current color. The
parameters are the same as for [draw_ellipse]. *)
val fill_circle : int -> int -> int -> unit
val fill_circle : int -> int -> r:int -> unit
(* Fill a circle with the current color. The
parameters are the same as for [draw_circle]. *)
@ -160,17 +162,17 @@ external make_image : color array array -> image = "gr_make_image"
is raised. *)
external dump_image : image -> color array array = "gr_dump_image"
(* Convert an image to a color matrix. *)
external draw_image : image -> int -> int -> unit = "gr_draw_image"
external draw_image : image -> x:int -> y:int -> unit = "gr_draw_image"
(* Draw the given image with lower left corner at the given point. *)
val get_image : int -> int -> int -> int -> image
val get_image : int -> int -> w:int -> h:int -> image
(* Capture the contents of a rectangle on the screen as an image.
The parameters are the same as for [fill_rect]. *)
external create_image : int -> int -> image = "gr_create_image"
external create_image : w:int -> h:int -> image = "gr_create_image"
(* [create_image w h] returns a new image [w] pixels wide and [h]
pixels tall, to be used in conjunction with [blit_image].
The initial image contents are random, except that no point
is transparent. *)
external blit_image : image -> int -> int -> unit = "gr_blit_image"
external blit_image : image -> x:int -> y:int -> unit = "gr_blit_image"
(* [blit_image img x y] copies screen pixels into the image [img],
modifying [img] in-place. The pixels copied are those inside the
rectangle with lower left corner at [x,y], and width and height
@ -223,6 +225,6 @@ val key_pressed : unit -> bool
(*** Sound *)
external sound : int -> int -> unit = "gr_sound"
external sound : freq:int -> ms:int -> unit = "gr_sound"
(* [sound freq dur] plays a sound at frequency [freq] (in hertz)
for a duration [dur] (in milliseconds). *)

2
otherlibs/labltk/lib/.cvsignore
View File

@ -1,3 +1,3 @@
*.ml *.mli labltktop
*.ml *.mli labltktop labltk labltklink labltkopt
modules
.depend

40
otherlibs/str/str.mli
View File

@ -56,20 +56,24 @@ val regexp_string_case_fold: string -> regexp
(*** String matching and searching *)
external string_match: regexp -> string -> int -> bool = "str_string_match"
external string_match: regexp -> string -> pos:int -> bool
= "str_string_match"
(* [string_match r s start] tests whether the characters in [s]
starting at position [start] match the regular expression [r].
The first character of a string has position [0], as usual. *)
external search_forward: regexp -> string -> int -> int = "str_search_forward"
external search_forward: regexp -> string -> pos:int -> int
= "str_search_forward"
(* [search_forward r s start] searchs the string [s] for a substring
matching the regular expression [r]. The search starts at position
[start] and proceeds towards the end of the string.
Return the position of the first character of the matched
substring, or raise [Not_found] if no substring matches. *)
external search_backward: regexp -> string -> int -> int = "str_search_backward"
external search_backward: regexp -> string -> pos:int -> int
= "str_search_backward"
(* Same as [search_forward], but the search proceeds towards the
beginning of the string. *)
external string_partial_match: regexp -> string -> int -> bool = "str_string_partial_match"
external string_partial_match: regexp -> string -> pos:int -> bool
= "str_string_partial_match"
(* Similar to [string_match], but succeeds whenever the argument
string is a prefix of a string that matches. This includes
the case of a true complete match. *)
@ -102,23 +106,23 @@ val group_end: int -> int
(*** Replacement *)
val global_replace: regexp -> string -> string -> string
val global_replace: regexp -> with:string -> string -> string
(* [global_replace regexp repl s] returns a string identical to [s],
except that all substrings of [s] that match [regexp] have been
replaced by [repl]. The replacement text [repl] can contain
[\1], [\2], etc; these sequences will be replaced by the text
matched by the corresponding group in the regular expression.
[\0] stands for the text matched by the whole regular expression. *)
val replace_first: regexp -> string -> string -> string
val replace_first: regexp -> with:string -> string -> string
(* Same as [global_replace], except that only the first substring
matching the regular expression is replaced. *)
val global_substitute: regexp -> (string -> string) -> string -> string
val global_substitute: regexp -> with:(string -> string) -> string -> string
(* [global_substitute regexp subst s] returns a string identical
to [s], except that all substrings of [s] that match [regexp]
have been replaced by the result of function [subst]. The
function [subst] is called once for each matching substring,
and receives [s] (the whole text) as argument. *)
val substitute_first: regexp -> (string -> string) -> string -> string
val substitute_first: regexp -> with:(string -> string) -> string -> string
(* Same as [global_substitute], except that only the first substring
matching the regular expression is replaced. *)
val replace_matched : string -> string -> string
@ -130,18 +134,18 @@ val replace_matched : string -> string -> string
(*** Splitting *)
val split: regexp -> string -> string list
val split: sep:regexp -> string -> string list
(* [split r s] splits [s] into substrings, taking as delimiters
the substrings that match [r], and returns the list of substrings.
For instance, [split (regexp "[ \t]+") s] splits [s] into
blank-separated words. An occurrence of the delimiter at the
beginning and at the end of the string is ignored. *)
val bounded_split: regexp -> string -> int -> string list
val bounded_split: sep:regexp -> string -> int -> string list
(* Same as [split], but splits into at most [n] substrings,
where [n] is the extra integer parameter. *)
val split_delim: regexp -> string -> string list
val bounded_split_delim: regexp -> string -> int -> string list
val split_delim: sep:regexp -> string -> string list
val bounded_split_delim: sep:regexp -> string -> int -> string list
(* Same as [split] and [bounded_split], but occurrences of the
delimiter at the beginning and at the end of the string are
recognized and returned as empty strings in the result.
@ -151,8 +155,8 @@ val bounded_split_delim: regexp -> string -> int -> string list
type split_result = Text of string | Delim of string
val full_split: regexp -> string -> split_result list
val bounded_full_split: regexp -> string -> int -> split_result list
val full_split: sep:regexp -> string -> split_result list
val bounded_full_split: sep:regexp -> string -> int -> split_result list
(* Same as [split_delim] and [bounded_split_delim], but returns
the delimiters as well as the substrings contained between
delimiters. The former are tagged [Delim] in the result list;
@ -162,17 +166,17 @@ val bounded_full_split: regexp -> string -> int -> split_result list
(*** Extracting substrings *)
val string_before: string -> int -> string
val string_before: string -> pos:int -> string
(* [string_before s n] returns the substring of all characters of [s]
that precede position [n] (excluding the character at
position [n]). *)
val string_after: string -> int -> string
val string_after: string -> pos:int -> string
(* [string_after s n] returns the substring of all characters of [s]
that follow position [n] (including the character at
position [n]). *)
val first_chars: string -> int -> string
val first_chars: string -> pos:int -> string
(* [first_chars s n] returns the first [n] characters of [s].
This is the same function as [string_before]. *)
val last_chars: string -> int -> string
val last_chars: string -> pos:int -> string
(* [last_chars s n] returns the last [n] characters of [s]. *)

2
otherlibs/systhreads/condition.mli
View File

@ -35,7 +35,7 @@ type t
(* The type of condition variables. *)
val create: unit -> t
(* Return a new condition variable. *)
val wait: t -> Mutex.t -> unit
val wait: t -> locking:Mutex.t -> unit
(* [wait c m] atomically unlocks the mutex [m] and suspends the
calling process on the condition variable [c]. The process will
restart after the condition variable [c] has been signalled.

6
otherlibs/systhreads/event.mli
View File

@ -26,7 +26,7 @@ val new_channel: unit -> 'a channel
type 'a event
(* The type of communication events returning a result of type ['a]. *)
val send: 'a channel -> 'a -> unit event
val send: to:'a channel -> 'a -> unit event
(* [send ch v] returns the event consisting in sending the value [v]
over the channel [ch]. The result value of this event is [()]. *)
val receive: 'a channel -> 'a event
@ -39,11 +39,11 @@ val always: 'a -> 'a event
val choose: 'a event list -> 'a event
(* [choose evl] returns the event that is the alternative of
all the events in the list [evl]. *)
val wrap: 'a event -> ('a -> 'b) -> 'b event
val wrap: 'a event -> fun:('a -> 'b) -> 'b event
(* [wrap ev fn] returns the event that performs the same communications
as [ev], then applies the post-processing function [fn]
on the return value. *)
val wrap_abort: 'a event -> (unit -> unit) -> 'a event
val wrap_abort: 'a event -> fun:(unit -> unit) -> 'a event
(* [wrap_abort ev fn] returns the event that performs
the same communications as [ev], but if it is not selected
the function [fn] is called after the synchronization. *)

8
otherlibs/systhreads/thread.mli
View File

@ -53,8 +53,8 @@ external join : t -> unit = "caml_thread_join"
val wait_read : Unix.file_descr -> unit
val wait_write : Unix.file_descr -> unit
(* These functions do nothing in this implementation. *)
val wait_timed_read : Unix.file_descr -> float -> bool
val wait_timed_write : Unix.file_descr -> float -> bool
val wait_timed_read : Unix.file_descr -> timeout:float -> bool
val wait_timed_write : Unix.file_descr -> timeout:float -> bool
(* Suspend the execution of the calling thread until at least
one character is available for reading ([wait_read]) or
one character can be written without blocking ([wait_write])
@ -65,8 +65,8 @@ val wait_timed_write : Unix.file_descr -> float -> bool
(* These functions return immediately [true] in the Win32
implementation. *)
val select :
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(* Suspend the execution of the calling thead until input/output
becomes possible on the given Unix file descriptors.

43
otherlibs/systhreads/threadUnix.mli
View File

@ -22,30 +22,34 @@
(*** Process handling *)
external execv : string -> string array -> unit = "unix_execv"
external execve : string -> string array -> string array -> unit
external execv : prog:string -> args:string array -> unit = "unix_execv"
external execve : prog:string -> args:string array -> env:string array -> unit
= "unix_execve"
external execvp : string -> string array -> unit = "unix_execvp"
external execvp : prog:string -> args:string array -> unit = "unix_execvp"
val wait : unit -> int * Unix.process_status
val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
val waitpid : flags:Unix.wait_flag list -> int -> int * Unix.process_status
val system : string -> Unix.process_status
(*** Basic input/output *)
val read : Unix.file_descr -> string -> int -> int -> int
val write : Unix.file_descr -> string -> int -> int -> int
val read : Unix.file_descr -> buffer:string -> pos:int -> len:int -> int
val write : Unix.file_descr -> buffer:string -> pos:int -> len:int -> int
(*** Polling *)
val select :
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(*** Input/output with timeout *)
val timed_read : Unix.file_descr -> string -> int -> int -> float -> int
val timed_write : Unix.file_descr -> string -> int -> int -> float -> int
val timed_read :
Unix.file_descr ->
buffer:string -> pos:int -> len:int -> timeout:float -> int
val timed_write :
Unix.file_descr ->
buffer:string -> pos:int -> len:int -> timeout:float -> int
(* Behave as [read] and [write], except that
[Unix_error(ETIMEDOUT,_,_)] is raised if no data is
available for reading or ready for writing after [d] seconds.
@ -64,15 +68,16 @@ external sleep : int -> unit = "unix_sleep"
(*** Sockets *)
val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr
val socket : domain:Unix.socket_domain ->
type:Unix.socket_type -> proto:int -> Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
external connect : Unix.file_descr -> Unix.sockaddr -> unit = "unix_connect"
val recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int
val sendto : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> Unix.sockaddr -> int
val recv : Unix.file_descr -> buffer:string ->
pos:int -> len:int -> flags:Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> int
val sendto : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> addr:Unix.sockaddr -> int
val open_connection : Unix.sockaddr -> in_channel * out_channel

2
otherlibs/threads/condition.mli
View File

@ -35,7 +35,7 @@ type t
(* The type of condition variables. *)
val create: unit -> t
(* Return a new condition variable. *)
val wait: t -> Mutex.t -> unit
val wait: t -> locking:Mutex.t -> unit
(* [wait c m] atomically unlocks the mutex [m] and suspends the
calling process on the condition variable [c]. The process will
restart after the condition variable [c] has been signalled.

6
otherlibs/threads/event.mli
View File

@ -26,7 +26,7 @@ val new_channel: unit -> 'a channel
type 'a event
(* The type of communication events returning a result of type ['a]. *)
val send: 'a channel -> 'a -> unit event
val send: to:'a channel -> 'a -> unit event
(* [send ch v] returns the event consisting in sending the value [v]
over the channel [ch]. The result value of this event is [()]. *)
val receive: 'a channel -> 'a event
@ -39,11 +39,11 @@ val always: 'a -> 'a event
val choose: 'a event list -> 'a event
(* [choose evl] returns the event that is the alternative of
all the events in the list [evl]. *)
val wrap: 'a event -> ('a -> 'b) -> 'b event
val wrap: 'a event -> fun:('a -> 'b) -> 'b event
(* [wrap ev fn] returns the event that performs the same communications
as [ev], then applies the post-processing function [fn]
on the return value. *)
val wrap_abort: 'a event -> (unit -> unit) -> 'a event
val wrap_abort: 'a event -> fun:(unit -> unit) -> 'a event
(* [wrap_abort ev fn] returns the event that performs
the same communications as [ev], but if it is not selected
the function [fn] is called after the synchronization. *)

2
otherlibs/threads/pervasives.ml
View File

@ -16,7 +16,7 @@
been redefined to not block the whole process, but only the calling
thread. *)
type 'a option = None | Some of 'a
(* type 'a option = None | Some of 'a *)
(* Exceptions *)

8
otherlibs/threads/thread.mli
View File

@ -58,15 +58,15 @@ val wait_write : Unix.file_descr -> unit
one character is available for reading ([wait_read]) or
one character can be written without blocking ([wait_write])
on the given Unix file descriptor. *)
val wait_timed_read : Unix.file_descr -> float -> bool
val wait_timed_write : Unix.file_descr -> float -> bool
val wait_timed_read : Unix.file_descr -> timeout:float -> bool
val wait_timed_write : Unix.file_descr -> timeout:float -> bool
(* Same as [wait_read] and [wait_write], but wait for at most
the amount of time given as second argument (in seconds).
Return [true] if the file descriptor is ready for input/output
and [false] if the timeout expired. *)
val select :
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(* Suspend the execution of the calling thead until input/output
becomes possible on the given Unix file descriptors.

49
otherlibs/threads/threadUnix.mli
View File

@ -22,22 +22,26 @@
(*** Process handling *)
val execv : string -> string array -> unit
val execve : string -> string array -> string array -> unit
val execvp : string -> string array -> unit
val execv : prog:string -> args:string array -> unit
val execve : prog:string -> args:string array -> env:string array -> unit
val execvp : prog:string -> args:string array -> unit
val wait : unit -> int * Unix.process_status
val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
val waitpid : flags:Unix.wait_flag list -> int -> int * Unix.process_status
val system : string -> Unix.process_status
(*** Basic input/output *)
val read : Unix.file_descr -> string -> int -> int -> int
val write : Unix.file_descr -> string -> int -> int -> int
val read : Unix.file_descr -> buffer:string -> pos:int -> len:int -> int
val write : Unix.file_descr -> buffer:string -> pos:int -> len:int -> int
(*** Input/output with timeout *)
val timed_read : Unix.file_descr -> string -> int -> int -> float -> int
val timed_write : Unix.file_descr -> string -> int -> int -> float -> int
val timed_read :
Unix.file_descr ->
buffer:string -> pos:int -> len:int -> timeout:float -> int
val timed_write :
Unix.file_descr ->
buffer:string -> pos:int -> len:int -> timeout:float -> int
(* Behave as [read] and [write], except that
[Unix_error(ETIMEDOUT,_,_)] is raised if no data is
available for reading or ready for writing after [d] seconds.
@ -46,8 +50,8 @@ val timed_write : Unix.file_descr -> string -> int -> int -> float -> int
(*** Polling *)
val select :
Unix.file_descr list -> Unix.file_descr list ->
Unix.file_descr list -> float ->
read:Unix.file_descr list -> write:Unix.file_descr list ->
exn:Unix.file_descr list -> timeout:float ->
Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
(*** Pipes and redirections *)
@ -62,19 +66,22 @@ val sleep : int -> unit
(*** Sockets *)
val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr
val socketpair : Unix.socket_domain -> Unix.socket_type -> int ->
Unix.file_descr * Unix.file_descr
val socket : domain:Unix.socket_domain ->
type:Unix.socket_type -> proto:int -> Unix.file_descr
val socketpair : domain:Unix.socket_domain -> type:Unix.socket_type ->
proto:int -> Unix.file_descr * Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> int
val sendto : Unix.file_descr -> string -> int -> int ->
Unix.msg_flag list -> Unix.sockaddr -> int
val recv : Unix.file_descr -> buffer:string ->
pos:int -> len:int -> flags:Unix.msg_flag list -> int
val recvfrom : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> int * Unix.sockaddr
val send : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> int
val sendto : Unix.file_descr -> buffer:string -> pos:int -> len:int ->
flags:Unix.msg_flag list -> addr:Unix.sockaddr -> int
val open_connection : Unix.sockaddr -> in_channel * out_channel
val establish_server :
(in_channel -> out_channel -> 'a) -> Unix.sockaddr -> unit
fun:(in:in_channel -> out:out_channel -> 'a) ->
addr:Unix.sockaddr -> unit

100
otherlibs/unix/unix.mli
View File

@ -145,14 +145,14 @@ type wait_flag =
[WUNTRACED] means report also the children that receive stop
signals. *)
val execv : string -> string array -> unit
val execv : prog:string -> args:string array -> unit
(* [execv prog args] execute the program in file [prog], with
the arguments [args], and the current process environment. *)
val execve : string -> string array -> string array -> unit
val execve : prog:string -> args:string array -> env:string array -> unit
(* Same as [execv], except that the third argument provides the
environment to the program executed. *)
val execvp : string -> string array -> unit
val execvpe : string -> string array -> string array -> unit
val execvp : prog:string -> args:string array -> unit
val execvpe : prog:string -> args:string array -> env:string array -> unit
(* Same as [execv] and [execvp] respectively, except that
the program is searched in the path. *)
val fork : unit -> int
@ -161,7 +161,7 @@ val fork : unit -> int
val wait : unit -> int * process_status
(* Wait until one of the children processes die, and return its pid
and termination status. *)
val waitpid : wait_flag list -> int -> int * process_status
val waitpid : flags:wait_flag list -> int -> int * process_status
(* Same as [wait], but waits for the process whose pid is given.
A pid of [-1] means wait for any child.
A pid of [0] means wait for any child in the same process group
@ -211,17 +211,17 @@ type open_flag =
type file_perm = int
(* The type of file access rights. *)
val openfile : string -> open_flag list -> file_perm -> file_descr
val openfile : string -> flags:open_flag list -> perm:file_perm -> file_descr
(* Open the named file with the given flags. Third argument is
the permissions to give to the file if it is created. Return
a file descriptor on the named file. *)
val close : file_descr -> unit
(* Close a file descriptor. *)
val read : file_descr -> string -> int -> int -> int
val read : file_descr -> buffer:string -> pos:int -> len:int -> int
(* [read fd buff ofs len] reads [len] characters from descriptor
[fd], storing them in string [buff], starting at position [ofs]
in string [buff]. Return the number of characters actually read. *)
val write : file_descr -> string -> int -> int -> int
val write : file_descr -> buffer:string -> pos:int -> len:int -> int
(* [write fd buff ofs len] writes [len] characters to descriptor
[fd], taking them from string [buff], starting at position [ofs]
in string [buff]. Return the number of characters actually
@ -256,11 +256,11 @@ type seek_command =
the current position, [SEEK_END] relative to the end of the
file. *)
val lseek : file_descr -> int -> seek_command -> int
val lseek : file_descr -> pos:int -> cmd:seek_command -> int
(* Set the current position for a file descriptor *)
val truncate : string -> int -> unit
val truncate : file:string -> len:int -> unit
(* Truncates the named file to the given size. *)
val ftruncate : file_descr -> int -> unit
val ftruncate : file_descr -> len:int -> unit
(* Truncates the file corresponding to the given descriptor
to the given size. *)
@ -306,9 +306,9 @@ val fstat : file_descr -> stats
val unlink : string -> unit
(* Removes the named file *)
val rename : string -> string -> unit
val rename : old:string -> new:string -> unit
(* [rename old new] changes the name of a file from [old] to [new]. *)
val link : string -> string -> unit
val link : string -> as:string -> unit
(* [link source dest] creates a hard link named [dest] to the file
named [new]. *)
@ -323,17 +323,17 @@ type access_permission =
(* Flags for the [access] call. *)
val chmod : string -> file_perm -> unit
val chmod : file:string -> perm:file_perm -> unit
(* Change the permissions of the named file. *)
val fchmod : file_descr -> file_perm -> unit
val fchmod : file_descr -> perm:file_perm -> unit
(* Change the permissions of an opened file. *)
val chown : string -> int -> int -> unit
val chown : file:string -> uid:int -> gid:int -> unit
(* Change the owner uid and owner gid of the named file. *)
val fchown : file_descr -> int -> int -> unit
val fchown : file_descr -> uid:int -> gid:int -> unit
(* Change the owner uid and owner gid of an opened file. *)
val umask : int -> int
(* Set the process creation mask, and return the previous mask. *)
val access : string -> access_permission list -> unit
val access : file:string -> perm:access_permission list -> unit
(* Check that the process has the given permissions over the named
file. Raise [Unix_error] otherwise. *)
@ -364,7 +364,7 @@ val clear_close_on_exec : file_descr -> unit
(*** Directories *)
val mkdir : string -> file_perm -> unit
val mkdir : string -> perm:file_perm -> unit
(* Create a directory with the given permissions. *)
val rmdir : string -> unit
(* Remove an empty directory. *)
@ -406,7 +406,8 @@ val mkfifo : string -> file_perm -> unit
(*** High-level process and redirection management *)
val create_process :
string -> string array -> file_descr -> file_descr -> file_descr -> int
prog:string -> args:string array ->
in:file_descr -> out:file_descr -> err:file_descr -> int
(* [create_process prog args new_stdin new_stdout new_stderr]
forks a new process that executes the program
in file [prog], with arguments [args]. The pid of the new
@ -424,8 +425,8 @@ val create_process :
outputs. *)
val create_process_env :
string -> string array -> string array ->
file_descr -> file_descr -> file_descr -> int
prog:string -> args:string array -> env:string array ->
in:file_descr -> out:file_descr -> err:file_descr -> int
(* [create_process_env prog args env new_stdin new_stdout new_stderr]
works as [create_process], except that the extra argument
[env] specifies the environment passed to the program. *)
@ -441,7 +442,7 @@ val open_process: string -> in_channel * out_channel
are buffered, hence be careful to call [flush] at the right times
to ensure correct synchronization. *)
val open_process_full:
string -> string array -> in_channel * out_channel * in_channel
string -> env:string array -> in_channel * out_channel * in_channel
(* Similar to [open_process], but the second argument specifies
the environment passed to the command. The result is a triple
of channels connected to the standard output, standard input,
@ -457,7 +458,7 @@ val close_process_full: in_channel * out_channel * in_channel -> process_status
(*** Symbolic links *)
val symlink : string -> string -> unit
val symlink : string -> as:string -> unit
(* [symlink source dest] creates the file [dest] as a symbolic link
to the file [source]. *)
val readlink : string -> string
@ -467,7 +468,8 @@ val readlink : string -> string
(*** Polling *)
val select :
file_descr list -> file_descr list -> file_descr list -> float ->
read:file_descr list -> write:file_descr list -> exn:file_descr list ->
timeout:float ->
file_descr list * file_descr list * file_descr list
(* Wait until some input/output operations become possible on
some channels. The three list arguments are, respectively, a set
@ -492,7 +494,7 @@ type lock_command =
(* Commands for [lockf]. *)
val lockf : file_descr -> lock_command -> int -> unit
val lockf : file_descr -> cmd:lock_command -> len:int -> unit
(* [lockf fd cmd size] puts a lock on a region of the file opened
as [fd]. The region starts at the current read/write position for
@ -507,7 +509,7 @@ val lockf : file_descr -> lock_command -> int -> unit
(*** Signals *)
val kill : int -> int -> unit
val kill : pid:int -> signal:int -> unit
(* [kill pid sig] sends signal number [sig] to the process
with id [pid]. *)
@ -580,7 +582,7 @@ val sleep : int -> unit
(* Stop execution for the given number of seconds. *)
val times : unit -> process_times
(* Return the execution times of the process. *)
val utimes : string -> float -> float -> unit
val utimes : file:string -> access:float -> modif:float -> unit
(* Set the last access time (second arg) and last modification time
(third arg) for a file. Times are expressed in seconds from
00:00:00 GMT, Jan. 1, 1970. *)
@ -710,12 +712,14 @@ type sockaddr =
domain; [addr] is the Internet address of the machine, and
[port] is the port number. *)
val socket : socket_domain -> socket_type -> int -> file_descr
val socket :
domain:socket_domain -> type:socket_type -> proto:int -> file_descr
(* Create a new socket in the given domain, and with the
given kind. The third argument is the protocol type; 0 selects
the default protocol for that kind of sockets. *)
val socketpair :
socket_domain -> socket_type -> int -> file_descr * file_descr
domain:socket_domain -> type:socket_type -> proto:int ->
file_descr * file_descr
(* Create a pair of unnamed sockets, connected together. *)
val accept : file_descr -> file_descr * sockaddr
(* Accept connections on the given socket. The returned descriptor
@ -725,7 +729,7 @@ val bind : file_descr -> sockaddr -> unit
(* Bind a socket to an address. *)
val connect : file_descr -> sockaddr -> unit
(* Connect a socket to an address. *)
val listen : file_descr -> int -> unit
val listen : file_descr -> max:int -> unit
(* Set up a socket for receiving connection requests. The integer
argument is the maximal number of pending requests. *)
@ -735,7 +739,7 @@ type shutdown_command =
| SHUTDOWN_ALL (* Close both *)
(* The type of commands for [shutdown]. *)
val shutdown : file_descr -> shutdown_command -> unit
val shutdown : file_descr -> cmd:shutdown_command -> unit
(* Shutdown a socket connection. [SHUTDOWN_SEND] as second argument
causes reads on the other end of the connection to return
an end-of-file condition.
@ -753,13 +757,18 @@ type msg_flag =
| MSG_PEEK
(* The flags for [recv], [recvfrom], [send] and [sendto]. *)
val recv : file_descr -> string -> int -> int -> msg_flag list -> int
val recv :
file_descr -> buffer:string -> pos:int -> len:int
-> flags:msg_flag list -> int
val recvfrom :
file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
file_descr -> buffer:string -> pos:int -> len:int
-> flags:msg_flag list -> int * sockaddr
(* Receive data from an unconnected socket. *)
val send : file_descr -> string -> int -> int -> msg_flag list -> int
val send : file_descr -> buffer:string -> pos:int -> len:int
-> flags:msg_flag list -> int
val sendto :
file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int
file_descr -> buffer:string -> pos:int -> len:int
-> flags:msg_flag list -> addr:sockaddr -> int
(* Send data over an unconnected socket. *)
type socket_option =
@ -771,9 +780,9 @@ type socket_option =
| SO_OOBINLINE (* Leave out-of-band data in line *)
(* The socket options settable with [setsockopt]. *)
val getsockopt : file_descr -> socket_option -> bool
val getsockopt : file_descr -> opt:socket_option -> bool
(* Return the current status of an option in the given socket. *)
val setsockopt : file_descr -> socket_option -> bool -> unit
val setsockopt : file_descr -> opt:socket_option -> bool -> unit
(* Set or clear an option in the given socket. *)
(*** High-level network connection functions *)
@ -787,7 +796,8 @@ val shutdown_connection : in_channel -> unit
(* ``Shut down'' a connection established with [open_connection];
that is, transmit an end-of-file condition to the server reading
on the other side of the connection. *)
val establish_server : (in_channel -> out_channel -> 'a) -> sockaddr -> unit
val establish_server : fun:(in:in_channel -> out:out_channel -> 'a) ->
addr:sockaddr -> unit
(* Establish a server on the given address.
The function given as first argument is called for each connection
with two buffered channels connected to the client. A new process
@ -831,10 +841,10 @@ val getprotobyname : string -> protocol_entry
val getprotobynumber : int -> protocol_entry
(* Find an entry in [protocols] with the given protocol number,
or raise [Not_found]. *)
val getservbyname : string -> string -> service_entry
val getservbyname : string -> proto:string -> service_entry
(* Find an entry in [services] with the given name, or raise
[Not_found]. *)
val getservbyport : int -> string -> service_entry
val getservbyport : int -> proto:string -> service_entry
(* Find an entry in [services] with the given service number,
or raise [Not_found]. *)
@ -900,7 +910,7 @@ val tcgetattr: file_descr -> terminal_io
type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
val tcsetattr: file_descr -> setattr_when -> terminal_io -> unit
val tcsetattr: file_descr -> when:setattr_when -> terminal_io -> unit
(* Set the status of the terminal referred to by the given
file descriptor. The second argument indicates when the
status change takes place: immediately ([TCSANOW]),
@ -910,7 +920,7 @@ val tcsetattr: file_descr -> setattr_when -> terminal_io -> unit
the output parameters; [TCSAFLUSH], when changing the input
parameters. *)
val tcsendbreak: file_descr -> int -> unit
val tcsendbreak: file_descr -> duration:int -> unit
(* Send a break condition on the given file descriptor.
The second argument is the duration of the break, in 0.1s units;
0 means standard duration (0.25s). *)
@ -921,7 +931,7 @@ val tcdrain: file_descr -> unit
type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
val tcflush: file_descr -> flush_queue -> unit
val tcflush: file_descr -> cmd:flush_queue -> unit
(* Discard data written on the given file descriptor but not yet
transmitted, or data received but not yet read, depending on the
second argument: [TCIFLUSH] flushes data received but not read,
@ -930,7 +940,7 @@ val tcflush: file_descr -> flush_queue -> unit
type flow_action = TCOOFF | TCOON | TCIOFF | TCION
val tcflow: file_descr -> flow_action -> unit
val tcflow: file_descr -> cmd:flow_action -> unit
(* Suspend or restart reception or transmission of data on
the given file descriptor, depending on the second argument:
[TCOOFF] suspends output, [TCOON] restarts output,

2
parsing/asttypes.mli
View File

@ -29,3 +29,5 @@ type private_flag = Private | Public
type mutable_flag = Immutable | Mutable
type virtual_flag = Virtual | Concrete
type label = string

18
parsing/lexer.mll
View File

@ -170,6 +170,8 @@ let identchar =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
let symbolchar2 =
['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~']
let decimal_literal = ['0'-'9']+
let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
let oct_literal = '0' ['o' 'O'] ['0'-'7']+
@ -182,6 +184,15 @@ rule token = parse
{ token lexbuf }
| "_"
{ UNDERSCORE }
| lowercase identchar * ':' [ ^ ':' '=' '>']
{ let s = Lexing.lexeme lexbuf in
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
LABEL (String.sub s 0 (String.length s - 2)) }
| ':' lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
let l = String.length s - 1 in
(* lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - l; *)
LABELID (String.sub s 1 l) }
| lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
try
@ -239,12 +250,14 @@ rule token = parse
| "#" { SHARP }
| "&" { AMPERSAND }
| "&&" { AMPERAMPER }
| "`" { BACKQUOTE }
| "'" { QUOTE }
| "(" { LPAREN }
| ")" { RPAREN }
| "*" { STAR }
| "," { COMMA }
| "?" { QUESTION }
| "??" { QUESTION2 }
| "->" { MINUSGREATER }
| "." { DOT }
| ".." { DOTDOT }
@ -262,6 +275,7 @@ rule token = parse
| "[<" { LBRACKETLESS }
| "]" { RBRACKET }
| "{" { LBRACE }
| "{=" { LBRACEEQUAL }
| "{<" { LBRACELESS }
| "|" { BAR }
| "||" { BARBAR }
@ -275,7 +289,9 @@ rule token = parse
| "-" { SUBTRACTIVE "-" }
| "-." { SUBTRACTIVE "-." }
| ['!' '?' '~'] symbolchar *
| ['!' '~'] symbolchar *
{ PREFIXOP(Lexing.lexeme lexbuf) }
| '?' symbolchar2 *
{ PREFIXOP(Lexing.lexeme lexbuf) }
| ['=' '<' '>' '|' '&' '$'] symbolchar *
{ INFIXOP0(Lexing.lexeme lexbuf) }

252
parsing/parser.mly
View File

@ -66,14 +66,14 @@ let mkassert e =
let excep = Ldot (Lident "Pervasives", "Assert_failure") in
let bucket = ghexp (Pexp_construct (excep, Some triple, false)) in
let raise_ = ghexp (Pexp_ident (Ldot (Lident "Pervasives", "raise"))) in
let raise_af = ghexp (Pexp_apply (raise_, [bucket])) in
let raise_af = ghexp (Pexp_apply (raise_, ["", bucket])) in
let under = ghpat Ppat_any in
let false_ = ghexp (Pexp_construct (Lident "false", None, false)) in
let try_e = ghexp (Pexp_try (e, [(under, false_)])) in
let not_ = ghexp (Pexp_ident (Ldot (Lident "Pervasives", "not"))) in
let not_try_e = ghexp (Pexp_apply (not_, [try_e])) in
let not_try_e = ghexp (Pexp_apply (not_, ["", try_e])) in
match e with
| {pexp_desc = Pexp_construct (Lident "false", None, false) } -> raise_af
| _ -> if !Clflags.noassert
@ -83,15 +83,15 @@ let mkassert e =
let mklazy e =
let void_pat = ghpat (Ppat_construct (Lident "()", None, false)) in
let f = ghexp (Pexp_function ([void_pat, e])) in
let f = ghexp (Pexp_function ("", None, [void_pat, e])) in
let delayed = Ldot (Lident "Lazy", "Delayed") in
let df = ghexp (Pexp_construct (delayed, Some f, false)) in
let r = ghexp (Pexp_ident (Ldot (Lident "Pervasives", "ref"))) in
ghexp (Pexp_apply (r, [df]))
ghexp (Pexp_apply (r, ["", df]))
;;
let mkinfix arg1 name arg2 =
mkexp(Pexp_apply(mkoperator name 2, [arg1; arg2]))
mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
let neg_float_string f =
if String.length f > 0 && f.[0] = '-'
@ -105,7 +105,7 @@ let mkuminus name arg =
| Pexp_constant(Const_float f) ->
mkexp(Pexp_constant(Const_float(neg_float_string f)))
| _ ->
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [arg]))
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
let rec mktailexp = function
[] ->
@ -161,6 +161,7 @@ let unclosed opening_name opening_num closing_name closing_num =
%token AND
%token AS
%token ASSERT
%token BACKQUOTE
%token BAR
%token BARBAR
%token BARRBRACKET
@ -204,8 +205,11 @@ let unclosed opening_name opening_num closing_name closing_num =
%token INHERIT
%token INITIALIZER
%token <int> INT
%token <string> LABEL
%token <string> LABELID
%token LAZY
%token LBRACE
%token LBRACEEQUAL
%token LBRACELESS
%token LBRACKET
%token LBRACKETBAR
@ -229,6 +233,7 @@ let unclosed opening_name opening_num closing_name closing_num =
%token <string> PREFIXOP
%token PRIVATE
%token QUESTION
%token QUESTION2
%token QUOTE
%token RBRACE
%token RBRACKET
@ -369,8 +374,8 @@ structure_item:
{ match $3 with
[{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
| _ -> mkstr(Pstr_value($2, List.rev $3)) }
| EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
{ mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
| EXTERNAL val_ident_colon core_type EQUAL primitive_declaration
{ mkstr(Pstr_primitive($2, {pval_type = $3; pval_prim = $5})) }
| TYPE type_declarations
{ mkstr(Pstr_type(List.rev $2)) }
| EXCEPTION UIDENT constructor_arguments
@ -420,10 +425,10 @@ signature:
| signature signature_item SEMISEMI { $2 :: $1 }
;
signature_item:
VAL val_ident COLON core_type
{ mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) }
| EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
{ mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) }
VAL val_ident_colon core_type
{ mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) }
| EXTERNAL val_ident_colon core_type EQUAL primitive_declaration
{ mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) }
| TYPE type_declarations
{ mksig(Psig_type(List.rev $2)) }
| EXCEPTION UIDENT constructor_arguments
@ -467,25 +472,25 @@ class_fun_binding:
{ $2 }
| COLON class_type EQUAL class_expr
{ mkclass(Pcl_constraint($4, $2)) }
| simple_pattern class_fun_binding
{ mkclass(Pcl_fun($1, $2)) }
| labeled_simple_pattern class_fun_binding
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
;
class_type_parameters:
/*empty*/ { [], symbol_rloc () }
| LBRACKET type_parameter_list RBRACKET { List.rev $2, symbol_rloc () }
;
class_fun_def:
simple_pattern MINUSGREATER class_expr
{ mkclass(Pcl_fun($1, $3)) }
| simple_pattern class_fun_def
{ mkclass(Pcl_fun($1, $2)) }
labeled_simple_pattern MINUSGREATER class_expr
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $3)) }
| labeled_simple_pattern class_fun_def
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
;
class_expr:
class_simple_expr
{ $1 }
| FUN class_fun_def
{ $2 }
| class_simple_expr simple_expr_list
| class_simple_expr simple_labeled_expr_list
{ mkclass(Pcl_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN class_expr
{ mkclass(Pcl_let ($2, List.rev $3, $5)) }
@ -562,10 +567,10 @@ value:
symbol_rloc () }
;
virtual_method:
METHOD PRIVATE VIRTUAL label COLON core_type
{ $4, Private, $6, symbol_rloc () }
| METHOD VIRTUAL private_flag label COLON core_type
{ $4, $3, $6, symbol_rloc () }
METHOD PRIVATE VIRTUAL label_colon core_type
{ $4, Private, $5, symbol_rloc () }
| METHOD VIRTUAL private_flag label_colon core_type
{ $4, $3, $5, symbol_rloc () }
;
concrete_method :
METHOD private_flag label fun_binding
@ -577,10 +582,15 @@ concrete_method :
class_type:
class_signature
{ $1 }
| simple_core_type MINUSGREATER class_type
{ mkcty(Pcty_fun($1, $3)) }
| core_type_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun(ghtyp(Ptyp_tuple(List.rev $1)), $3)) }
| QUESTION LABEL simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun("?" ^ $2 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$3]);
ptyp_loc = $3.ptyp_loc},
$5)) }
| LABEL simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun($1, $2, $4)) }
| simple_core_type_or_tuple MINUSGREATER class_type
{ mkcty(Pcty_fun("", $1, $3)) }
;
class_signature:
LBRACKET core_type_comma_list RBRACKET clty_longident
@ -613,8 +623,8 @@ class_sig_fields:
| class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
;
value_type:
mutable_flag label COLON core_type
{ $2, $1, Some $4, symbol_rloc () }
mutable_flag label_colon core_type
{ $2, $1, Some $3, symbol_rloc () }
/*
XXX Should be removed
| mutable_flag label
@ -622,8 +632,8 @@ XXX Should be removed
*/
;
method_type:
METHOD private_flag label COLON core_type
{ $3, $2, $5, symbol_rloc () }
METHOD private_flag label_colon core_type
{ $3, $2, $4, symbol_rloc () }
;
constrain:
core_type EQUAL core_type { $1, $3, symbol_rloc () }
@ -633,8 +643,8 @@ class_descriptions:
| class_description { [$1] }
;
class_description:
virtual_flag class_type_parameters LIDENT COLON class_type
{ {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $5;
virtual_flag class_type_parameters label_colon class_type
{ {pci_virt = $1; pci_params = $2; pci_name = $3; pci_expr = $4;
pci_loc = symbol_rloc ()} }
;
class_type_declarations:
@ -654,10 +664,26 @@ seq_expr:
| expr SEMI { $1 }
| expr SEMI seq_expr { mkexp(Pexp_sequence($1, $3)) }
;
labeled_simple_pattern:
QUESTION label_pattern LBRACEEQUAL seq_expr RBRACE
{ ("?" ^ fst $2, Some $4, snd $2) }
| QUESTION label_pattern
{ ("?" ^ fst $2, None, snd $2) }
| label_pattern
{ (fst $1, None, snd $1) }
| simple_pattern
{ ("", None, $1) }
;
label_pattern:
LABEL simple_pattern
{ ($1, $2) }
| LABELID
{ ($1, mkpat(Ppat_var $1)) }
;
expr:
simple_expr
{ $1 }
| simple_expr simple_expr_list %prec prec_appl
| simple_expr simple_labeled_expr_list %prec prec_appl
{ mkexp(Pexp_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN seq_expr %prec prec_let
{ mkexp(Pexp_let($2, List.rev $3, $5)) }
@ -666,13 +692,13 @@ expr:
| PARSER opt_pat opt_bar parser_cases %prec prec_fun
{ Pstream.cparser ($2, List.rev $4) }
| FUNCTION opt_bar match_cases %prec prec_fun
{ mkexp(Pexp_function(List.rev $3)) }
| FUN simple_pattern fun_def %prec prec_fun
{ mkexp(Pexp_function([$2, $3])) }
{ mkexp(Pexp_function("", None, List.rev $3)) }
| FUN labeled_simple_pattern fun_def %prec prec_fun
{ let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
| MATCH seq_expr WITH opt_bar match_cases %prec prec_match
{ mkexp(Pexp_match($2, List.rev $5)) }
| MATCH seq_expr WITH PARSER opt_pat opt_bar parser_cases %prec prec_match
{ mkexp(Pexp_apply(Pstream.cparser ($5, List.rev $7), [$2])) }
{ mkexp(Pexp_apply(Pstream.cparser ($5, List.rev $7), ["",$2])) }
| TRY seq_expr WITH opt_bar match_cases %prec prec_try
{ mkexp(Pexp_try($2, List.rev $5)) }
| TRY seq_expr WITH error %prec prec_try
@ -681,6 +707,8 @@ expr:
{ mkexp(Pexp_tuple(List.rev $1)) }
| constr_longident simple_expr %prec prec_constr_appl
{ mkexp(Pexp_construct($1, Some $2, false)) }
| name_tag simple_expr %prec prec_constr_appl
{ mkexp(Pexp_variant($1, Some $2)) }
| IF seq_expr THEN expr ELSE expr %prec prec_if
{ mkexp(Pexp_ifthenelse($2, $4, Some $6)) }
| IF seq_expr THEN expr %prec prec_if
@ -729,10 +757,10 @@ expr:
{ mkexp(Pexp_setfield($1, $3, $5)) }
| simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")),
[$1; $4; $7])) }
["",$1; "",$4; "",$7])) }
| simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")),
[$1; $4; $7])) }
["",$1; "",$4; "",$7])) }
| label LESSMINUS expr
{ mkexp(Pexp_setinstvar($1, $3)) }
/*
@ -757,6 +785,8 @@ simple_expr:
{ mkexp(Pexp_constant $1) }
| constr_longident
{ mkexp(Pexp_construct($1, None, false)) }
| name_tag
{ mkexp(Pexp_variant($1, None)) }
| LPAREN seq_expr RPAREN
{ $2 }
| LPAREN seq_expr error
@ -771,12 +801,12 @@ simple_expr:
{ mkexp(Pexp_field($1, $3)) }
| simple_expr DOT LPAREN seq_expr RPAREN
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")),
[$1; $4])) }
["",$1; "",$4])) }
| simple_expr DOT LPAREN seq_expr error
{ unclosed "(" 3 ")" 5 }
| simple_expr DOT LBRACKET seq_expr RBRACKET
{ mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")),
[$1; $4])) }
["",$1; "",$4])) }
| simple_expr DOT LBRACKET seq_expr error
{ unclosed "[" 3 "]" 5 }
| LBRACE record_expr RBRACE
@ -800,7 +830,7 @@ simple_expr:
| LBRACKET expr_semi_list opt_semi error
{ unclosed "[" 1 "]" 4 }
| PREFIXOP simple_expr
{ mkexp(Pexp_apply(mkoperator $1 1, [$2])) }
{ mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) }
| NEW class_longident
{ mkexp(Pexp_new($2)) }
| LBRACELESS field_expr_list opt_semi GREATERRBRACE
@ -812,12 +842,34 @@ simple_expr:
| simple_expr SHARP label
{ mkexp(Pexp_send($1, $3)) }
;
simple_labeled_expr_list:
labeled_simple_expr
{ [$1] }
| simple_labeled_expr_list labeled_simple_expr
{ $2 :: $1 }
;
labeled_simple_expr:
simple_expr
{ ("", $1) }
| label_expr
{ $1 }
| QUESTION label_expr
{ ("?" ^ fst $2, snd $2) }
;
label_expr:
LABEL simple_expr
{ ($1, $2) }
| LABELID
{ ($1, mkexp(Pexp_ident(Lident $1))) }
;
/*
simple_expr_list:
simple_expr
{ [$1] }
| simple_expr_list simple_expr
{ $2 :: $1 }
;
*/
let_bindings:
let_binding { [$1] }
| let_bindings AND let_binding { $3 :: $1 }
@ -833,8 +885,8 @@ fun_binding:
{ $2 }
| type_constraint EQUAL seq_expr %prec prec_let
{ let (t, t') = $1 in mkexp(Pexp_constraint($3, t, t')) }
| simple_pattern fun_binding
{ mkexp(Pexp_function[$1,$2]) }
| labeled_simple_pattern fun_binding
{ let (l, o, p) = $1 in mkexp(Pexp_function(l, o, [p, $2])) }
;
parser_cases:
parser_case { [$1] }
@ -869,7 +921,7 @@ opt_pat:
;
opt_err:
/* empty */ { None }
| QUESTION expr %prec prec_list { Some $2 }
| QUESTION2 expr %prec prec_list { Some $2 }
;
stream_expr:
stream_expr_component { [$1] }
@ -884,8 +936,9 @@ match_cases:
| match_cases BAR pattern match_action { ($3, $4) :: $1 }
;
fun_def:
match_action { $1 }
| simple_pattern fun_def { mkexp(Pexp_function[$1,$2]) }
match_action { $1 }
| labeled_simple_pattern fun_def
{ let (l,o,p) = $1 in mkexp(Pexp_function(l, o, [p, $2])) }
;
match_action:
MINUSGREATER seq_expr { $2 }
@ -934,6 +987,8 @@ pattern:
{ mkpat(Ppat_tuple(List.rev $1)) }
| constr_longident pattern %prec prec_constr_appl
{ mkpat(Ppat_construct($1, Some $2, false)) }
| name_tag pattern %prec prec_constr_appl
{ mkpat(Ppat_variant($1, Some $2)) }
| pattern COLONCOLON pattern
{ mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])),
false)) }
@ -951,6 +1006,8 @@ simple_pattern:
{ mkrangepat $1 $3 }
| constr_longident
{ mkpat(Ppat_construct($1, None, false)) }
| name_tag
{ mkpat(Ppat_variant($1, None)) }
| LBRACE lbl_pattern_list opt_semi RBRACE
{ mkpat(Ppat_record(List.rev $2)) }
| LBRACE lbl_pattern_list opt_semi error
@ -971,8 +1028,12 @@ simple_pattern:
{ unclosed "(" 1 ")" 3 }
| LPAREN pattern COLON core_type RPAREN
{ mkpat(Ppat_constraint($2, $4)) }
| LPAREN LABEL core_type RPAREN
{ mkpat(Ppat_constraint(mkpat(Ppat_var $2), $3)) }
| LPAREN pattern COLON core_type error
{ unclosed "(" 1 ")" 5 }
| LPAREN LABEL core_type error
{ unclosed "(" 1 ")" 4 }
;
pattern_comma_list:
@ -1059,7 +1120,7 @@ label_declarations:
| label_declarations SEMI label_declaration { $3 :: $1 }
;
label_declaration:
mutable_flag LIDENT COLON core_type { ($2, $1, $4) }
mutable_flag label_colon core_type { ($2, $1, $3) }
;
/* "with" constraints (additional type equations over signature components) */
@ -1084,15 +1145,23 @@ with_constraint:
/* Core types */
core_type:
simple_core_type
core_type2
{ $1 }
| core_type MINUSGREATER core_type %prec prec_type_arrow
{ mktyp(Ptyp_arrow($1, $3)) }
| core_type_tuple
{ mktyp(Ptyp_tuple(List.rev $1)) }
| core_type AS type_parameter
| core_type2 AS type_parameter
{ mktyp(Ptyp_alias($1, $3)) }
;
core_type2:
simple_core_type_or_tuple
{ $1 }
| QUESTION LABEL core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow("?" ^ $2 ,
{ptyp_desc = Ptyp_constr(Lident "option", [$3]);
ptyp_loc = $3.ptyp_loc}, $5)) }
| LABEL core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow($1, $2, $4)) }
| core_type2 MINUSGREATER core_type2 %prec prec_type_arrow
{ mktyp(Ptyp_arrow("", $1, $3)) }
;
simple_core_type:
QUOTE ident
@ -1112,18 +1181,62 @@ simple_core_type:
{ mktyp(Ptyp_object $2) }
| LESS GREATER
{ mktyp(Ptyp_object []) }
| SHARP class_longident
{ mktyp(Ptyp_class($2, [])) }
| simple_core_type SHARP class_longident %prec prec_constr_appl
{ mktyp(Ptyp_class($3, [$1])) }
| LPAREN core_type_comma_list RPAREN SHARP class_longident
| SHARP class_longident opt_present
{ mktyp(Ptyp_class($2, [], $3)) }
| simple_core_type SHARP class_longident opt_present %prec prec_constr_appl
{ mktyp(Ptyp_class($3, [$1], $4)) }
| LPAREN core_type_comma_list RPAREN SHARP class_longident opt_present
%prec prec_constr_appl
{ mktyp(Ptyp_class($5, List.rev $2)) }
{ mktyp(Ptyp_class($5, List.rev $2, $6)) }
| LBRACKET row_field_list RBRACKET
{ let l = List.rev $2 in
mktyp(Ptyp_variant(l, true, List.map (fun (p,_,_) -> p) l)) }
| LBRACKET GREATER row_field_list RBRACKET
{ let l = List.rev $3 in
mktyp(Ptyp_variant(l, false, List.map (fun (p,_,_) -> p) l)) }
| LBRACKETLESS row_field_list opt_opened RBRACKET
{ mktyp(Ptyp_variant(List.rev $2, not $3, [])) }
| LBRACKETLESS row_field_list opt_opened GREATER name_tag_list RBRACKET
{ mktyp(Ptyp_variant(List.rev $2, not $3, List.rev $5)) }
| LBRACKET RBRACKET
{ mktyp(Ptyp_variant([],true,[])) }
;
opt_opened:
BAR DOTDOT { true }
| /* empty */ { false }
;
row_field_list:
row_field { [$1] }
| row_field_list BAR row_field { $3 :: $1 }
;
row_field:
name_tag opt_ampersand amper_type_list { ($1, $2, List.rev $3) }
| name_tag { ($1, true, []) }
;
opt_ampersand:
AMPERSAND { true }
| /* empty */ { false }
;
amper_type_list:
core_type { [$1] }
| amper_type_list AMPERSAND core_type { $3 :: $1 }
;
opt_present:
LBRACKET GREATER name_tag_list RBRACKET { List.rev $3 }
| /* empty */ { [] }
;
name_tag_list:
name_tag { [$1] }
| name_tag_list name_tag { $2 :: $1 }
;
core_type_tuple:
simple_core_type STAR simple_core_type { [$3; $1] }
| core_type_tuple STAR simple_core_type { $3 :: $1 }
;
simple_core_type_or_tuple:
simple_core_type { $1 }
| core_type_tuple { mktyp(Ptyp_tuple(List.rev $1)) }
;
core_type_comma_list:
core_type COMMA core_type { [$3; $1] }
| core_type_comma_list COMMA core_type { $3 :: $1 }
@ -1138,11 +1251,15 @@ meth_list:
| DOTDOT { [mkfield Pfield_var] }
;
field:
label COLON core_type { mkfield(Pfield($1, $3)) }
label_colon core_type { mkfield(Pfield($1, $2)) }
;
label:
LIDENT { $1 }
;
label_colon:
LIDENT COLON { $1 }
| LABEL { $1 }
;
/* Constants */
@ -1167,6 +1284,11 @@ val_ident:
LIDENT { $1 }
| LPAREN operator RPAREN { $2 }
;
val_ident_colon:
LIDENT COLON { $1 }
| LPAREN operator RPAREN COLON { $2 }
| LABEL { $1 }
;
operator:
PREFIXOP { $1 }
| INFIXOP0 { $1 }
@ -1187,7 +1309,8 @@ operator:
;
constr_ident:
UIDENT { $1 }
| LBRACKET RBRACKET { "[]" }
/* useless, and conflicts with variants
| LBRACKET RBRACKET { "[]" } */
| LPAREN RPAREN { "()" }
| COLONCOLON { "::" }
| FALSE { "false" }
@ -1246,6 +1369,9 @@ toplevel_directive:
/* Miscellaneous */
name_tag:
BACKQUOTE ident { $2 }
;
rec_flag:
/* empty */ { Nonrecursive }
| REC { Recursive }

17
parsing/parsetree.mli
View File

@ -25,12 +25,13 @@ type core_type =
and core_type_desc =
Ptyp_any
| Ptyp_var of string
| Ptyp_arrow of core_type * core_type
| Ptyp_arrow of label * core_type * core_type
| Ptyp_tuple of core_type list
| Ptyp_constr of Longident.t * core_type list
| Ptyp_object of core_field_type list
| Ptyp_class of Longident.t * core_type list
| Ptyp_class of Longident.t * core_type list * label list
| Ptyp_alias of core_type * string
| Ptyp_variant of (label * bool * core_type list) list * bool * label list
and core_field_type =
{ pfield_desc: core_field_desc;
@ -62,6 +63,7 @@ and pattern_desc =
| Ppat_constant of constant
| Ppat_tuple of pattern list
| Ppat_construct of Longident.t * pattern option * bool
| Ppat_variant of label * pattern option
| Ppat_record of (Longident.t * pattern) list
| Ppat_array of pattern list
| Ppat_or of pattern * pattern
@ -75,12 +77,13 @@ and expression_desc =
Pexp_ident of Longident.t
| Pexp_constant of constant
| Pexp_let of rec_flag * (pattern * expression) list * expression
| Pexp_function of (pattern * expression) list
| Pexp_apply of expression * expression list
| Pexp_function of label * expression option * (pattern * expression) list
| Pexp_apply of expression * (label * expression) list
| Pexp_match of expression * (pattern * expression) list
| Pexp_try of expression * (pattern * expression) list
| Pexp_tuple of expression list
| Pexp_construct of Longident.t * expression option * bool
| Pexp_variant of label * expression option
| Pexp_record of (Longident.t * expression) list * expression option
| Pexp_field of expression * Longident.t
| Pexp_setfield of expression * Longident.t * expression
@ -128,7 +131,7 @@ and class_type =
and class_type_desc =
Pcty_constr of Longident.t * core_type list
| Pcty_signature of class_signature
| Pcty_fun of core_type * class_type
| Pcty_fun of label * core_type * class_type
and class_signature = core_type * class_type_field list
@ -152,8 +155,8 @@ and class_expr =
and class_expr_desc =
Pcl_constr of Longident.t * core_type list
| Pcl_structure of class_structure
| Pcl_fun of pattern * class_expr
| Pcl_apply of class_expr * expression list
| Pcl_fun of label * expression option * pattern * class_expr
| Pcl_apply of class_expr * (label * expression) list
| Pcl_let of rec_flag * (pattern * expression) list * class_expr
| Pcl_constraint of class_expr * class_type

39
parsing/printast.ml
View File

@ -97,8 +97,9 @@ let rec core_type i x =
match x.ptyp_desc with
| Ptyp_any -> line i "Ptyp_any\n";
| Ptyp_var (s) -> line i "Ptyp_var %s\n" s;
| Ptyp_arrow (ct1, ct2) ->
| Ptyp_arrow (l, ct1, ct2) ->
line i "Ptyp_arrow\n";
string i l;
core_type i ct1;
core_type i ct2;
| Ptyp_tuple l ->
@ -107,12 +108,18 @@ let rec core_type i x =
| Ptyp_constr (li, l) ->
line i "Ptyp_constr %a\n" fmt_longident li;
list i core_type l;
| Ptyp_variant (l, closed, low) ->
line i "Ptyp_variant\n";
list i row_field l;
bool i closed;
list i string low
| Ptyp_object (l) ->
line i "Ptyp_object\n";
list i core_field_type l;
| Ptyp_class (li, l) ->
| Ptyp_class (li, l, low) ->
line i "Ptyp_class %a\n" fmt_longident li;
list i core_type l;
list i string low
| Ptyp_alias (ct, s) ->
line i "Ptyp_alias \"%s\"\n" s;
core_type i ct;
@ -126,12 +133,17 @@ and core_field_type i x =
core_type i ct;
| Pfield_var -> line i "Pfield_var\n";
and row_field i (l, pre, tyl) =
string i l;
bool i pre;
list i core_type tyl
and pattern i x =
line i "pattern %a\n" fmt_location x.ppat_loc;
let i = i+1 in
match x.ppat_desc with
| Ppat_any -> line i "Ppat_any\n";
| Ppat_var (s) -> line i "PPat_var \"%s\"\n" s;
| Ppat_var (s) -> line i "Ppat_var \"%s\"\n" s;
| Ppat_alias (p, s) ->
line i "Ppat_alias \"%s\"\n" s;
pattern i p;
@ -143,6 +155,9 @@ and pattern i x =
line i "Ppat_construct %a\n" fmt_longident li;
option i pattern po;
bool i b;
| Ppat_variant (l, po) ->
line i "Ppat_variant `%s\n" l;
option i pattern po;
| Ppat_record (l) ->
line i "Ppat_record\n";
list i longident_x_pattern l;
@ -168,13 +183,14 @@ and expression i x =
line i "Pexp_let %a\n" fmt_rec_flag rf;
list i pattern_x_expression_def l;
expression i e;
| Pexp_function (l) ->
line i "Pexp_function\n";
| Pexp_function (p, eo, l) ->
line i "Pexp_function \"%s\"\n" p;
option i expression eo;
list i pattern_x_expression_case l;
| Pexp_apply (e, l) ->
line i "Pexp_apply\n";
expression i e;
list i expression l;
list i argument l;
| Pexp_match (e, l) ->
line i "Pexp_match\n";
expression i e;
@ -190,6 +206,9 @@ and expression i x =
line i "Pexp_construct %a\n" fmt_longident li;
option i expression eo;
bool i b;
| Pexp_variant (l, eo) ->
line i "Pexp_variant `%s\n" l;
option i expression eo;
| Pexp_record (l, eo) ->
line i "Pexp_record\n";
list i longident_x_expression l;
@ -248,6 +267,10 @@ and expression i x =
module_expr i me;
expression i e;
and argument i (l,e) =
string i l;
expression i e;
and value_description i x =
line i "value_description\n";
core_type (i+1) x.pval_type;
@ -287,8 +310,8 @@ and class_type i x =
| Pcty_signature (cs) ->
line i "Pcty_signature\n";
class_signature i cs;
| Pcty_fun (co, cl) ->
line i "Pcty_fun\n";
| Pcty_fun (l, co, cl) ->
line i "Pcty_fun \"%s\"\n" l;
core_type i co;
class_type i cl;

11
parsing/pstream.ml
View File

@ -40,9 +40,10 @@ let sexp = Pexp_ident (Lident "%strm")
let econ c x = ghexp (Pexp_construct (Ldot (Lident "Stream", c), x, false))
let pcon c x = ghpat (Ppat_construct (Ldot (Lident "Stream", c), x, false))
let afun f x =
ghexp (Pexp_apply (ghexp (Pexp_ident (Ldot (Lident "Stream", f))), x))
ghexp (Pexp_apply (ghexp (Pexp_ident (Ldot (Lident "Stream", f))),
List.map (fun a -> "", a) x))
let araise c x =
ghexp (Pexp_apply (ghexp (Pexp_ident (Lident "raise")), [econ c x]))
ghexp (Pexp_apply (ghexp (Pexp_ident (Lident "raise")), ["", econ c x]))
let esome x = ghexp (Pexp_construct (Lident "Some", Some x, false))
@ -62,7 +63,7 @@ let stream_pattern_component skont =
| Spat_nterm (p, e) ->
(ghexp
(Pexp_try
(esome (ghexp (Pexp_apply (e, [ghexp sexp]))),
(esome (ghexp (Pexp_apply (e, ["", ghexp sexp]))),
[(pcon "Failure" None,
ghexp (Pexp_construct (Lident "None", None, false)))])),
p, skont)
@ -113,12 +114,12 @@ let cparser (bpo, pc) =
in
ghpat (Ppat_constraint (ghpat spat, t))
in
mkexp (Pexp_function [(p, e)])
mkexp (Pexp_function ("", None, [p, e]))
(* streams *)
let clazy e = ghexp (Pexp_function [(ghpat Ppat_any, e)])
let clazy e = ghexp (Pexp_function ("", None, [ghpat Ppat_any, e]))
let rec cstream_aux =
function

4
stdlib/.depend
View File

@ -34,6 +34,8 @@ map.cmo: map.cmi
map.cmx: map.cmi
marshal.cmo: string.cmi marshal.cmi
marshal.cmx: string.cmx marshal.cmi
morelabel.cmo: buffer.cmi hashtbl.cmi map.cmi set.cmi morelabel.cmi
morelabel.cmx: buffer.cmx hashtbl.cmx map.cmx set.cmx morelabel.cmi
obj.cmo: marshal.cmi obj.cmi
obj.cmx: marshal.cmx obj.cmi
oo.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi sort.cmi \
@ -58,6 +60,8 @@ sort.cmo: array.cmi sort.cmi
sort.cmx: array.cmx sort.cmi
stack.cmo: list.cmi stack.cmi
stack.cmx: list.cmx stack.cmi
stdlabel.cmo: array.cmi list.cmi string.cmi stdlabel.cmi
stdlabel.cmx: array.cmx list.cmx string.cmx stdlabel.cmi
stream.cmo: list.cmi obj.cmi string.cmi stream.cmi
stream.cmx: list.cmx obj.cmx string.cmx stream.cmi
string.cmo: char.cmi list.cmi string.cmi

31
stdlib/Makefile
View File

@ -102,6 +102,37 @@ pervasives.p.cmx: pervasives.ml
oo.cmi: oo.mli
$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
# stdlabel.cmo and morelabel.cmo use -labelize
stdlabel.cmo: stdlabel.ml
$(CAMLC) $(COMPFLAGS) -labelize -c stdlabel.ml
stdlabel.cmx: stdlabel.ml
$(CAMLOPT) $(OPTCOMPFLAGS) -labelize -c stdlabel.ml
stdlabel.p.cmx: stdlabel.ml
@if test -f stdlabel.cmx; then mv stdlabel.cmx stdlabel.n.cmx; else :; fi
@if test -f stdlabel.o; then mv stdlabel.o stdlabel.n.o; else :; fi
$(CAMLOPT) $(OPTCOMPFLAGS) -p -labelize -c stdlabel.ml
mv stdlabel.cmx stdlabel.p.cmx
mv stdlabel.o stdlabel.p.o
@if test -f stdlabel.n.cmx; then mv stdlabel.n.cmx stdlabel.cmx; else :; fi
@if test -f stdlabel.n.o; then mv stdlabel.n.o stdlabel.o; else :; fi
morelabel.cmo: morelabel.ml
$(CAMLC) $(COMPFLAGS) -labelize -c morelabel.ml
morelabel.cmx: morelabel.ml
$(CAMLOPT) $(OPTCOMPFLAGS) -labelize -c morelabel.ml
morelabel.p.cmx: morelabel.ml
@if test -f morelabel.cmx; then mv morelabel.cmx morelabel.n.cmx; else :; fi
@if test -f morelabel.o; then mv morelabel.o morelabel.n.o; else :; fi
$(CAMLOPT) $(OPTCOMPFLAGS) -p -labelize -c morelabel.ml
mv morelabel.cmx morelabel.p.cmx
mv morelabel.o morelabel.p.o
@if test -f morelabel.n.cmx; then mv morelabel.n.cmx morelabel.cmx; else :; fi
@if test -f morelabel.n.o; then mv morelabel.n.o morelabel.o; else :; fi
.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
.mli.cmi:

5
stdlib/arg.mli
View File

@ -51,7 +51,8 @@ type spec =
(* The concrete type describing the behavior associated
with a keyword. *)
val parse : (string * spec * string) list -> (string -> unit) -> string -> unit
val parse : keywords:(string * spec * string) list ->
others:(string -> unit) -> errmsg:string -> unit
(*
[Arg.parse speclist anonfun usage_msg] parses the command line.
[speclist] is a list of triples [(key, spec, doc)].
@ -84,7 +85,7 @@ exception Bad of string
message to reject invalid arguments.
*)
val usage: (string * spec * string) list -> string -> unit
val usage: keywords:(string * spec * string) list -> errmsg:string -> unit
(*
[Arg.usage speclist usage_msg] prints an error message including
the list of valid options. This is the same message that

28
stdlib/array.mli
View File

@ -29,8 +29,8 @@ external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
Raise [Invalid_argument "Array.set"] if [n] is outside the range
0 to [Array.length a - 1].
You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
external make: int -> 'a -> 'a array = "make_vect"
external create: int -> 'a -> 'a array = "make_vect"
external make: len:int -> 'a -> 'a array = "make_vect"
external create: len:int -> 'a -> 'a array = "make_vect"
(* [Array.make n x] returns a fresh array of length [n],
initialized with [x].
All the elements of this new array are initially
@ -42,13 +42,13 @@ external create: int -> 'a -> 'a array = "make_vect"
If the value of [x] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2].
[Array.create] is a deprecated alias for [Array.make]. *)
val init: int -> (int -> 'a) -> 'a array
val init: len:int -> fun:(int -> 'a) -> 'a array
(* [Array.init n f] returns a fresh array of length [n],
with element number [i] initialized to the result of [f i].
In other terms, [Array.init n f] tabulates the results of [f]
applied to the integers [0] to [n-1]. *)
val make_matrix: int -> int -> 'a -> 'a array array
val create_matrix: int -> int -> 'a -> 'a array array
val make_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
val create_matrix: dimx:int -> dimy:int -> 'a -> 'a array array
(* [Array.make_matrix dimx dimy e] returns a two-dimensional array
(an array of arrays) with first dimension [dimx] and
second dimension [dimy]. All the elements of this new matrix
@ -66,7 +66,7 @@ val append: 'a array -> 'a array -> 'a array
concatenation of the arrays [v1] and [v2]. *)
val concat: 'a array list -> 'a array
(* Same as [Array.append], but catenates a list of arrays. *)
val sub: 'a array -> int -> int -> 'a array
val sub: 'a array -> pos:int -> len:int -> 'a array
(* [Array.sub a start len] returns a fresh array of length [len],
containing the elements number [start] to [start + len - 1]
of array [a].
@ -76,12 +76,12 @@ val sub: 'a array -> int -> int -> 'a array
val copy: 'a array -> 'a array
(* [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *)
val fill: 'a array -> int -> int -> 'a -> unit
val fill: 'a array -> pos:int -> len:int -> 'a -> unit
(* [Array.fill a ofs len x] modifies the array [a] in place,
storing [x] in elements number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
designate a valid subarray of [a]. *)
val blit: 'a array -> int -> 'a array -> int -> int -> unit
val blit: 'a array -> pos:int -> to:'a array -> to_pos:int -> len:int -> unit
(* [Array.blit v1 o1 v2 o2 len] copies [len] elements
from array [v1], starting at element number [o1], to array [v2],
starting at element number [o2]. It works correctly even if
@ -95,24 +95,24 @@ val to_list: 'a array -> 'a list
val of_list: 'a list -> 'a array
(* [Array.of_list l] returns a fresh array containing the elements
of [l]. *)
val iter: ('a -> unit) -> 'a array -> unit
val iter: fun:('a -> unit) -> 'a array -> unit
(* [Array.iter f a] applies function [f] in turn to all
the elements of [a]. It is equivalent to
[f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
val map: ('a -> 'b) -> 'a array -> 'b array
val map: fun:('a -> 'b) -> 'a array -> 'b array
(* [Array.map f a] applies function [f] to all the elements of [a],
and builds an array with the results returned by [f]:
[[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
val iteri: (int -> 'a -> unit) -> 'a array -> unit
val mapi: (int -> 'a -> 'b) -> 'a array -> 'b array
val iteri: fun:(i:int -> 'a -> unit) -> 'a array -> unit
val mapi: fun:(i:int -> 'a -> 'b) -> 'a array -> 'b array
(* Same as [Array.iter] and [Array.map] respectively, but the
function is applied to the index of the element as first argument,
and the element itself as second argument. *)
val fold_left: ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
val fold_left: fun:(acc:'a -> 'b -> 'a) -> acc:'a -> 'b array -> 'a
(* [Array.fold_left f x a] computes
[f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
where [n] is the length of the array [a]. *)
val fold_right: ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
val fold_right: fun:('b -> acc:'a -> 'a) -> 'b array -> acc:'a -> 'a
(* [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *)

6
stdlib/buffer.mli
View File

@ -52,17 +52,17 @@ val add_char : t -> char -> unit
val add_string : t -> string -> unit
(* [add_string b s] appends the string [s] at the end of
the buffer [b]. *)
val add_substring : t -> string -> int -> int -> unit
val add_substring : t -> string -> pos:int -> len:int -> unit
(* [add_substring b s ofs len] takes [len] characters from offset
[ofs] in string [s] and appends them at the end of the buffer [b]. *)
val add_buffer : t -> t -> unit
(* [add_buffer b1 b2] appends the current contents of buffer [b2]
at the end of buffer [b1]. [b2] is not modified. *)
val add_channel : t -> in_channel -> int -> unit
val add_channel : t -> in_channel -> len:int -> unit
(* [add_channel b ic n] reads exactly [n] character from the
input channel [ic] and stores them at the end of buffer [b].
Raise [End_of_file] if the channel contains fewer than [n]
characters. *)
val output_buffer : out_channel -> t -> unit
val output_buffer : to:out_channel -> t -> unit
(* [output_buffer oc b] writes the current contents of buffer [b]
on the output channel [oc]. *)

6
stdlib/digest.mli
View File

@ -23,16 +23,16 @@ type t = string
(* The type of digests: 16-character strings. *)
val string: string -> t
(* Return the digest of the given string. *)
val substring: string -> int -> int -> t
val substring: string -> pos:int -> len:int -> t
(* [Digest.substring s ofs len] returns the digest of the substring
of [s] starting at character number [ofs] and containing [len]
characters. *)
external channel: in_channel -> int -> t = "md5_chan"
external channel: in_channel -> len:int -> t = "md5_chan"
(* [Digest.channel ic len] reads [len] characters from channel [ic]
and returns their digest. *)
val file: string -> t
(* Return the digest of the file whose name is given. *)
val output: out_channel -> t -> unit
val output: to:out_channel -> t -> unit
(* Write a digest on the given output channel. *)
val input: in_channel -> t
(* Read a digest from the given input channel. *)

6
stdlib/filename.mli
View File

@ -29,10 +29,10 @@ val is_implicit : string -> bool
with an explicit reference to the current directory ([./] or
[../] in Unix), [false] if it starts with an explicit reference
to the root directory or the current directory. *)
val check_suffix : string -> string -> bool
val check_suffix : string -> suff:string -> bool
(* [check_suffix name suff] returns [true] if the filename [name]
ends with the suffix [suff]. *)
val chop_suffix : string -> string -> string
val chop_suffix : string -> suff:string -> string
(* [chop_suffix name suff] removes the suffix [suff] from
the filename [name]. The behavior is undefined if [name] does not
end with the suffix [suff]. *)
@ -49,7 +49,7 @@ val dirname : string -> string
current directory to [dirname name] (with [Sys.chdir]),
references to [basename name] (which is a relative file name)
designate the same file as [name] before the call to [Sys.chdir]. *)
val temp_file: string -> string -> string
val temp_file: prefix:string -> suffix:string -> string
(* [temp_file prefix suffix] returns the name of a
non-existent temporary file in the temporary directory.
The base name of the temporary file is formed by concatenating

12
stdlib/format.mli
View File

@ -224,7 +224,8 @@ val set_formatter_out_channel : out_channel -> unit;;
(* Redirect the pretty-printer output to the given channel. *)
val set_formatter_output_functions :
(string -> int -> int -> unit) -> (unit -> unit) -> unit;;
out:(buffer:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) -> unit;;
(* [set_formatter_output_functions out flush] redirects the
pretty-printer output to the functions [out] and [flush].
The [out] function performs the pretty-printer output.
@ -234,13 +235,14 @@ val set_formatter_output_functions :
called whenever the pretty-printer is flushed using
[print_flush] or [print_newline]. *)
val get_formatter_output_functions :
unit -> (string -> int -> int -> unit) * (unit -> unit);;
unit -> (buffer:string -> pos:int -> len:int -> unit) * (unit -> unit);;
(* Return the current output functions of the pretty-printer. *)
(*** Changing the meaning of indentation and line breaking *)
val set_all_formatter_output_functions :
(string -> int -> int -> unit) -> (unit -> unit) ->
(unit -> unit) -> (int -> unit) -> unit;;
out:(buffer:string -> pos:int -> len:int -> unit) ->
flush:(unit -> unit) ->
newline:(unit -> unit) -> space:(int -> unit) -> unit;;
(* [set_all_formatter_output_functions out flush outnewline outspace]
redirects the pretty-printer output to the functions
[out] and [flush] as described in
@ -257,7 +259,7 @@ val set_all_formatter_output_functions :
[outspace] and [outnewline] are [out (String.make n ' ') 0 n]
and [out "\n" 0 1]. *)
val get_all_formatter_output_functions : unit ->
(string -> int -> int -> unit) * (unit -> unit) *
(buffer:string -> pos:int -> len:int -> unit) * (unit -> unit) *
(unit -> unit) * (int -> unit);;
(* Return the current output functions of the pretty-printer,
including line breaking and indentation functions. *)

24
stdlib/hashtbl.mli
View File

@ -30,32 +30,32 @@ val create : int -> ('a,'b) t
val clear : ('a, 'b) t -> unit
(* Empty a hash table. *)
val add : ('a, 'b) t -> 'a -> 'b -> unit
val add : ('a, 'b) t -> key:'a -> data:'b -> unit
(* [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl].
Previous bindings for [x] are not removed, but simply
hidden. That is, after performing [Hashtbl.remove tbl x],
the previous binding for [x], if any, is restored.
(Same behavior as with association lists.) *)
val find : ('a, 'b) t -> 'a -> 'b
val find : ('a, 'b) t -> key:'a -> 'b
(* [Hashtbl.find tbl x] returns the current binding of [x] in [tbl],
or raises [Not_found] if no such binding exists. *)
val find_all : ('a, 'b) t -> 'a -> 'b list
val find_all : ('a, 'b) t -> key:'a -> 'b list
(* [Hashtbl.find_all tbl x] returns the list of all data
associated with [x] in [tbl].
The current binding is returned first, then the previous
bindings, in reverse order of introduction in the table. *)
val mem : ('a, 'b) t -> 'a -> bool
val mem : ('a, 'b) t -> key:'a -> bool
(* [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *)
val remove : ('a, 'b) t -> 'a -> unit
val remove : ('a, 'b) t -> key:'a -> unit
(* [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl],
restoring the previous binding if it exists.
It does nothing if [x] is not bound in [tbl]. *)
val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
val iter : fun:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit
(* [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl].
[f] receives the key as first argument, and the associated value
as second argument. The order in which the bindings are passed to
@ -89,12 +89,12 @@ module type S =
type 'a t
val create: int -> 'a t
val clear: 'a t -> unit
val add: 'a t -> key -> 'a -> unit
val remove: 'a t -> key -> unit
val find: 'a t -> key -> 'a
val find_all: 'a t -> key -> 'a list
val mem: 'a t -> key -> bool
val iter: (key -> 'a -> unit) -> 'a t -> unit
val add: 'a t -> key:key -> data:'a -> unit
val remove: 'a t -> key:key -> unit
val find: 'a t -> key:key -> 'a
val find_all: 'a t -> key:key -> 'a list
val mem: 'a t -> key:key -> bool
val iter: fun:(key:key -> data:'a -> unit) -> 'a t -> unit
end
module Make(H: HashedType): (S with type key = H.t)

4
stdlib/lexing.mli
View File

@ -40,7 +40,7 @@ val from_string : string -> lexbuf
the given string. Reading starts from the first character in
the string. An end-of-input condition is generated when the
end of the string is reached. *)
val from_function : (string -> int -> int) -> lexbuf
val from_function : (buffer:string -> len:int -> int) -> lexbuf
(* Create a lexer buffer with the given function as its reading method.
When the scanner needs more characters, it will call the given
function, giving it a character string [s] and a character
@ -62,7 +62,7 @@ val from_function : (string -> int -> int) -> lexbuf
val lexeme : lexbuf -> string
(* [Lexing.lexeme lexbuf] returns the string matched by
the regular expression. *)
val lexeme_char : lexbuf -> int -> char
val lexeme_char : lexbuf -> pos:int -> char
(* [Lexing.lexeme_char lexbuf i] returns character number [i] in
the matched string. *)
val lexeme_start : lexbuf -> int

56
stdlib/list.mli
View File

@ -33,7 +33,7 @@ val hd : 'a list -> 'a
val tl : 'a list -> 'a list
(* Return the given list without its first element. Raise
[Failure "tl"] if the list is empty. *)
val nth : 'a list -> int -> 'a
val nth : 'a list -> pos:int -> 'a
(* Return the n-th element of the given list.
The first element (head of the list) is at position 0.
Raise [Failure "nth"] if the list is too short. *)
@ -54,47 +54,49 @@ val flatten : 'a list list -> 'a list
(** Iterators *)
val iter : ('a -> unit) -> 'a list -> unit
val iter : fun:('a -> unit) -> 'a list -> unit
(* [List.iter f [a1; ...; an]] applies function [f] in turn to
[a1; ...; an]. It is equivalent to
[begin f a1; f a2; ...; f an; () end]. *)
val map : ('a -> 'b) -> 'a list -> 'b list
val map : fun:('a -> 'b) -> 'a list -> 'b list
(* [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
and builds the list [[f a1; ...; f an]]
with the results returned by [f]. Not tail-recursive. *)
val rev_map : ('a -> 'b) -> 'a list -> 'b list
val rev_map : fun:('a -> 'b) -> 'a list -> 'b list
(* [List.rev_map f l] gives the same result as
[List.rev (List.map f l)], but is tail-recursive and
more efficient. *)
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val fold_left : fun:(acc:'a -> 'b -> 'a) -> acc:'a -> 'b list -> 'a
(* [List.fold_left f a [b1; ...; bn]] is
[f (... (f (f a b1) b2) ...) bn]. *)
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
val fold_right : fun:('a -> acc:'b -> 'b) -> 'a list -> acc:'b -> 'b
(* [List.fold_right f [a1; ...; an] b] is
[f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *)
(** Iterators on two lists *)
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
val iter2 : fun:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
(* [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
[f a1 b1; ...; f an bn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val map2 : fun:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.map2 f [a1; ...; an] [b1; ...; bn]] is
[[f a1 b1; ...; f an bn]].
Raise [Invalid_argument] if the two lists have
different lengths. Not tail-recursive. *)
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val rev_map2 : fun:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* [List.rev_map2 f l] gives the same result as
[List.rev (List.map2 f l)], but is tail-recursive and
more efficient. *)
val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
val fold_left2 :
fun:(acc:'a -> 'b -> 'c -> 'a) -> acc:'a -> 'b list -> 'c list -> 'a
(* [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
[f (... (f (f a b1 c1) b2 c2) ...) bn cn].
Raise [Invalid_argument] if the two lists have
different lengths. *)
val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
val fold_right2 :
fun:('a -> 'b -> acc:'c -> 'c) -> 'a list -> 'b list -> acc:'c -> 'c
(* [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
[f a1 b1 (f a2 b2 (... (f an bn c) ...))].
Raise [Invalid_argument] if the two lists have
@ -102,42 +104,42 @@ val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
(** List scanning *)
val for_all : ('a -> bool) -> 'a list -> bool
val for_all : pred:('a -> bool) -> 'a list -> bool
(* [for_all p [a1; ...; an]] checks if all elements of the list
satisfy the predicate [p]. That is, it returns
[(p a1) && (p a2) && ... && (p an)]. *)
val exists : ('a -> bool) -> 'a list -> bool
val exists : pred:('a -> bool) -> 'a list -> bool
(* [exists p [a1; ...; an]] checks if at least one element of
the list satisfies the predicate [p]. That is, it returns
[(p a1) || (p a2) || ... || (p an)]. *)
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val for_all2 : pred:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : pred:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(* Same as [for_all] and [exists], but for a two-argument predicate.
Raise [Invalid_argument] if the two lists have
different lengths. *)
val mem : 'a -> 'a list -> bool
val mem : elt:'a -> 'a list -> bool
(* [mem a l] is true if and only if [a] is equal
to an element of [l]. *)
val memq : 'a -> 'a list -> bool
val memq : elt:'a -> 'a list -> bool
(* Same as [mem], but uses physical equality instead of structural
equality to compare list elements. *)
(** List searching *)
val find : ('a -> bool) -> 'a list -> 'a
val find : pred:('a -> bool) -> 'a list -> 'a
(* [find p l] returns the first element of the list [l]
that satisfies the predicate [p].
Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *)
val filter : ('a -> bool) -> 'a list -> 'a list
val find_all : ('a -> bool) -> 'a list -> 'a list
val filter : pred:('a -> bool) -> 'a list -> 'a list
val find_all : pred:('a -> bool) -> 'a list -> 'a list
(* [filter p l] returns all the elements of the list [l]
that satisfies the predicate [p]. The order of the elements
in the input list is preserved. [find_all] is another name
for [filter]. *)
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
val partition : pred:('a -> bool) -> 'a list -> 'a list * 'a list
(* [partition p l] returns a pair of lists [(l1, l2)], where
[l1] is the list of all the elements of [l] that
satisfy the predicate [p], and [l2] is the list of all the
@ -146,30 +148,30 @@ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
(** Association lists *)
val assoc : 'a -> ('a * 'b) list -> 'b
val assoc : key:'a -> ('a * 'b) list -> 'b
(* [assoc a l] returns the value associated with key [a] in the list of
pairs [l]. That is,
[assoc a [ ...; (a,b); ...] = b]
if [(a,b)] is the leftmost binding of [a] in list [l].
Raise [Not_found] if there is no value associated with [a] in the
list [l]. *)
val assq : 'a -> ('a * 'b) list -> 'b
val assq : key:'a -> ('a * 'b) list -> 'b
(* Same as [assoc], but uses physical equality instead of structural
equality to compare keys. *)
val mem_assoc : 'a -> ('a * 'b) list -> bool
val mem_assoc : key:'a -> ('a * 'b) list -> bool
(* Same as [assoc], but simply return true if a binding exists,
and false if no bindings exist for the given key. *)
val mem_assq : 'a -> ('a * 'b) list -> bool
val mem_assq : key:'a -> ('a * 'b) list -> bool
(* Same as [mem_assoc], but uses physical equality instead of
structural equality to compare keys. *)
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
val remove_assoc : key:'a -> ('a * 'b) list -> ('a * 'b) list
(* [remove_assoc a l] returns the list of
pairs [l] without the first pair with key [a], if any.
Not tail-recursive. *)
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
val remove_assq : key:'a -> ('a * 'b) list -> ('a * 'b) list
(* Same as [remove_assq], but uses physical equality instead
of structural equality to compare keys. Not tail-recursive. *)

14
stdlib/map.mli
View File

@ -44,32 +44,32 @@ module type S =
(* The type of maps from type [key] to type ['a]. *)
val empty: 'a t
(* The empty map. *)
val add: key -> 'a -> 'a t -> 'a t
val add: key:key -> data:'a -> 'a t -> 'a t
(* [add x y m] returns a map containing the same bindings as
[m], plus a binding of [x] to [y]. If [x] was already bound
in [m], its previous binding disappears. *)
val find: key -> 'a t -> 'a
val find: key:key -> 'a t -> 'a
(* [find x m] returns the current binding of [x] in [m],
or raises [Not_found] if no such binding exists. *)
val remove: key -> 'a t -> 'a t
val remove: key:key -> 'a t -> 'a t
(* [remove x m] returns a map containing the same bindings as
[m], except for [x] which is unbound in the returned map. *)
val mem: key -> 'a t -> bool
val mem: key:key -> 'a t -> bool
(* [mem x m] returns [true] if [m] contains a binding for [m],
and [false] otherwise. *)
val iter: (key -> 'a -> unit) -> 'a t -> unit
val iter: fun:(key:key -> data:'a -> unit) -> 'a t -> unit
(* [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
as second argument. The order in which the bindings are passed to
[f] is unspecified. Only current bindings are presented to [f]:
bindings hidden by more recent bindings are not passed to [f]. *)
val map: ('a -> 'b) -> 'a t -> 'b t
val map: fun:('a -> 'b) -> 'a t -> 'b t
(* [map f m] returns a map with same domain as [m], where the
associated value [a] of all bindings of [m] has been
replaced by the result of the application of [f] to [a].
The order in which the associated values are passed to [f]
is unspecified. *)
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val fold: fun:(key:key -> data:'a -> acc:'b -> 'b) -> 'a t -> acc:'b -> 'b
(* [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
where [k1 ... kN] are the keys of all bindings in [m],
and [d1 ... dN] are the associated data.

13
stdlib/marshal.mli
View File

@ -47,7 +47,7 @@ type extern_flags =
| Closures (* Send function closures *)
(* The flags to the [Marshal.to_*] functions below. *)
external to_channel: out_channel -> 'a -> extern_flags list -> unit
external to_channel: out_channel -> data:'a -> flags:extern_flags list -> unit
= "output_value"
(* [Marshal.to_channel chan v flags] writes the representation
of [v] on channel [chan]. The [flags] argument is a
@ -78,14 +78,15 @@ external to_channel: out_channel -> 'a -> extern_flags list -> unit
at un-marshaling time, using an MD5 digest of the code
transmitted along with the code position.) *)
external to_string: 'a -> extern_flags list -> string
external to_string: data:'a -> flags:extern_flags list -> string
= "output_value_to_string"
(* [Marshal.to_string v flags] returns a string containing
the representation of [v] as a sequence of bytes.
The [flags] argument has the same meaning as for
[Marshal.to_channel]. *)
val to_buffer: string -> int -> int -> 'a -> extern_flags list -> int
val to_buffer: string -> pos:int -> len:int ->
data:'a -> flags:extern_flags list -> int
(* [Marshal.to_buffer buff ofs len v flags] marshals the value [v],
storing its byte representation in the string [buff],
starting at character number [ofs], and writing at most
@ -100,15 +101,15 @@ external from_channel: in_channel -> 'a = "input_value"
one of the [Marshal.to_*] functions, and reconstructs and
returns the corresponding value.*)
val from_string: string -> int -> 'a
val from_string: string -> pos:int -> 'a
(* [Marshal.from_string buff ofs] unmarshals a structured value
like [Marshal.from_channel] does, except that the byte
representation is not read from a channel, but taken from
the string [buff], starting at position [ofs]. *)
val header_size : int
val data_size : string -> int -> int
val total_size : string -> int -> int
val data_size : string -> pos:int -> int
val total_size : string -> pos:int -> int
(* The bytes representing a marshaled value are composed of
a fixed-size header and a variable-sized data part,
whose size can be determined from the header.

8
stdlib/obj.mli
View File

@ -24,11 +24,11 @@ external magic : 'a -> 'b = "%identity"
external is_block : t -> bool = "obj_is_block"
external tag : t -> int = "obj_tag"
external size : t -> int = "%obj_size"
external field : t -> int -> t = "%obj_field"
external set_field : t -> int -> t -> unit = "%obj_set_field"
external new_block : int -> int -> t = "obj_block"
external field : t -> pos:int -> t = "%obj_field"
external set_field : t -> pos:int -> t -> unit = "%obj_set_field"
external new_block : int -> len:int -> t = "obj_block"
external dup : t -> t = "obj_dup"
external truncate : t -> int -> unit = "obj_truncate"
external truncate : t -> len:int -> unit = "obj_truncate"
val no_scan_tag : int
val closure_tag : int

2
stdlib/oo.mli
View File

@ -14,7 +14,7 @@
(* Module [Oo]: object-oriented extension *)
val copy : < .. > as 'a -> 'a
val copy : (< .. > as 'a) -> 'a
(* [Oo.copy o] returns a copy of object [o], that is a fresh
object with the same methods and instance variables as [o] *)

2
stdlib/pervasives.ml
View File

@ -12,7 +12,7 @@
(* $Id$ *)
type 'a option = None | Some of 'a
(* type 'a option = None | Some of 'a *)
(* Exceptions *)

26
stdlib/pervasives.mli
View File

@ -42,7 +42,7 @@
(* The type of arrays whose elements have type ['a]. *)
(*- type 'a list = [] | :: of 'a * 'a list *)
(* The type of lists whose elements have type ['a]. *)
type 'a option = None | Some of 'a
(* type 'a option = None | Some of 'a *)
(* The type of optional values. *)
(*- type ('a, 'b, 'c) format *)
(* The type of format strings. ['a] is the type of the parameters
@ -440,7 +440,7 @@ val open_out_bin : string -> out_channel
so that no translation takes place during writes. On operating
systems that do not distinguish between text mode and binary
mode, this function behaves like [open_out]. *)
val open_out_gen : open_flag list -> int -> string -> out_channel
val open_out_gen : mode:open_flag list -> perm:int -> string -> out_channel
(* [open_out_gen mode rights filename] opens the file named
[filename] for writing, as above. The extra argument [mode]
specify the opening mode. The extra argument [rights] specifies
@ -451,32 +451,32 @@ val flush : out_channel -> unit
performing all pending writes on that channel.
Interactive programs must be careful about flushing standard
output and standard error at the right time. *)
val output_char : out_channel -> char -> unit
val output_char : to:out_channel -> char -> unit
(* Write the character on the given output channel. *)
val output_string : out_channel -> string -> unit
val output_string : to:out_channel -> string -> unit
(* Write the string on the given output channel. *)
val output : out_channel -> string -> int -> int -> unit
val output : out_channel -> buffer:string -> pos:int -> len:int -> unit
(* [output chan buff ofs len] writes [len] characters from string
[buff], starting at offset [ofs], to the output channel [chan].
Raise [Invalid_argument "output"] if [ofs] and [len] do not
designate a valid substring of [buff]. *)
val output_byte : out_channel -> int -> unit
val output_byte : to:out_channel -> int -> unit
(* Write one 8-bit integer (as the single character with that code)
on the given output channel. The given integer is taken modulo
256. *)
val output_binary_int : out_channel -> int -> unit
val output_binary_int : to:out_channel -> int -> unit
(* Write one integer in binary format on the given output channel.
The only reliable way to read it back is through the
[input_binary_int] function. The format is compatible across
all machines for a given version of Objective Caml. *)
val output_value : out_channel -> 'a -> unit
val output_value : to:out_channel -> 'a -> unit
(* Write the representation of a structured value of any type
to a channel. Circularities and sharing inside the value
are detected and preserved. The object can be read back,
by the function [input_value]. See the description of module
[Marshal] for more information. [output_value] is equivalent
to [Marshal.to_channel] with an empty list of flags. *)
val seek_out : out_channel -> int -> unit
val seek_out : out_channel -> pos:int -> unit
(* [seek_out chan pos] sets the current writing position to [pos]
for channel [chan]. This works only for regular files. On
files of other kinds (such as terminals, pipes and sockets),
@ -512,7 +512,7 @@ val open_in_bin : string -> in_channel
so that no translation takes place during reads. On operating
systems that do not distinguish between text mode and binary
mode, this function behaves like [open_in]. *)
val open_in_gen : open_flag list -> int -> string -> in_channel
val open_in_gen : mode:open_flag list -> perm:int -> string -> in_channel
(* [open_in_gen mode rights filename] opens the file named
[filename] for reading, as above. The extra arguments
[mode] and [rights] specify the opening mode and file permissions.
@ -526,7 +526,7 @@ val input_line : in_channel -> string
all characters read, without the newline character at the end.
Raise [End_of_file] if the end of the file is reached
at the beginning of line. *)
val input : in_channel -> string -> int -> int -> int
val input : in_channel -> buffer:string -> pos:int -> len:int -> int
(* [input chan buff ofs len] attempts to read [len] characters
from channel [chan], storing them in string [buff], starting at
character number [ofs]. It returns the actual number of characters
@ -537,7 +537,7 @@ val input : in_channel -> string -> int -> int -> int
called again to read the remaining characters, if desired.
Exception [Invalid_argument "input"] is raised if [ofs] and [len]
do not designate a valid substring of [buff]. *)
val really_input : in_channel -> string -> int -> int -> unit
val really_input : in_channel -> buffer:string -> pos:int -> len:int -> unit
(* [really_input chan buff ofs len] reads [len] characters
from channel [chan], storing them in string [buff], starting at
character number [ofs]. Raise [End_of_file] if
@ -559,7 +559,7 @@ val input_value : in_channel -> 'a
This function is identical to [Marshal.from_channel];
see the description of module [Marshal] for more information,
in particular concerning the lack of type safety. *)
val seek_in : in_channel -> int -> unit
val seek_in : in_channel -> pos:int -> unit
(* [seek_in chan pos] sets the current reading position to [pos]
for channel [chan]. This works only for regular files. On
files of other kinds, the behavior is unspecified. *)

2
stdlib/queue.mli
View File

@ -36,7 +36,7 @@ val clear : 'a t -> unit
(* Discard all elements from a queue. *)
val length: 'a t -> int
(* Return the number of elements in a queue. *)
val iter: ('a -> unit) -> 'a t -> unit
val iter: fun:('a -> unit) -> 'a t -> unit
(* [iter f q] applies [f] in turn to all elements of [q],
from the least recently entered to the most recently entered.
The queue itself is unchanged. *)

10
stdlib/set.mli
View File

@ -46,14 +46,14 @@ module type S =
(* The empty set. *)
val is_empty: t -> bool
(* Test whether a set is empty or not. *)
val mem: elt -> t -> bool
val mem: elt:elt -> t -> bool
(* [mem x s] tests whether [x] belongs to the set [s]. *)
val add: elt -> t -> t
val add: elt:elt -> t -> t
(* [add x s] returns a set containing all elements of [s],
plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
val singleton: elt -> t
(* [singleton x] returns the one-element set containing only [x]. *)
val remove: elt -> t -> t
val remove: elt:elt -> t -> t
(* [remove x s] returns a set containing all elements of [s],
except [x]. If [x] was not in [s], [s] is returned unchanged. *)
val union: t -> t -> t
@ -69,11 +69,11 @@ module type S =
val subset: t -> t -> bool
(* [subset s1 s2] tests whether the set [s1] is a subset of
the set [s2]. *)
val iter: (elt -> unit) -> t -> unit
val iter: fun:(elt -> unit) -> t -> unit
(* [iter f s] applies [f] in turn to all elements of [s].
The order in which the elements of [s] are presented to [f]
is unspecified. *)
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
val fold: fun:(elt -> acc:'a -> 'a) -> t -> acc:'a -> 'a
(* [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
where [x1 ... xN] are the elements of [s].
The order in which elements of [s] are presented to [f] is

6
stdlib/sort.mli
View File

@ -14,19 +14,19 @@
(* Module [Sort]: sorting and merging lists *)
val list : ('a -> 'a -> bool) -> 'a list -> 'a list
val list : order:('a -> 'a -> bool) -> 'a list -> 'a list
(* Sort a list in increasing order according to an ordering predicate.
The predicate should return [true] if its first argument is
less than or equal to its second argument. *)
val array : ('a -> 'a -> bool) -> 'a array -> unit
val array : order:('a -> 'a -> bool) -> 'a array -> unit
(* Sort an array in increasing order according to an
ordering predicate.
The predicate should return [true] if its first argument is
less than or equal to its second argument.
The array is sorted in place. *)
val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
val merge : order:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
(* Merge two lists according to the given predicate.
Assuming the two argument lists are sorted according to the
predicate, [merge] returns a sorted list containing the elements

2
stdlib/stack.mli
View File

@ -33,7 +33,7 @@ val clear : 'a t -> unit
(* Discard all elements from a stack. *)
val length: 'a t -> int
(* Return the number of elements in a stack. *)
val iter: ('a -> unit) -> 'a t -> unit
val iter: fun:('a -> unit) -> 'a t -> unit
(* [iter f s] applies [f] in turn to all elements of [s],
from the element at the top of the stack to the element at the
bottom of the stack. The stack itself is unchanged. *)

2
stdlib/stream.mli
View File

@ -45,7 +45,7 @@ val of_channel : in_channel -> char t;;
(** Stream iterator *)
val iter : ('a -> unit) -> 'a t -> unit;;
val iter : fun:('a -> unit) -> 'a t -> unit;;
(* [Stream.iter f s] scans the whole stream s, applying function [f]
in turn to each stream element encountered. *)

35
stdlib/string.mli
View File

@ -31,32 +31,32 @@ external set : string -> int -> char -> unit = "%string_safe_set"
0 to [(String.length s - 1)].
You can also write [s.[n] <- c] instead of [String.set s n c]. *)
external create : int -> string = "create_string"
external create : len:int -> string = "create_string"
(* [String.create n] returns a fresh string of length [n].
The string initially contains arbitrary characters.
Raise [Invalid_argument] if [n <= 0] or [n > Sys.max_string_length].
*)
val make : int -> char -> string
val make : len:int -> char -> string
(* [String.make n c] returns a fresh string of length [n],
filled with the character [c].
Raise [Invalid_argument] if [n <= 0] or [n > Sys.max_string_length].
*)
val copy : string -> string
(* Return a copy of the given string. *)
val sub : string -> int -> int -> string
val sub : string -> pos:int -> len:int -> string
(* [String.sub s start len] returns a fresh string of length [len],
containing the characters number [start] to [start + len - 1]
of string [s].
Raise [Invalid_argument] if [start] and [len] do not
designate a valid substring of [s]; that is, if [start < 0],
or [len < 0], or [start + len > String.length s]. *)
val fill : string -> int -> int -> char -> unit
val fill : string -> pos:int -> len:int -> char -> unit
(* [String.fill s start len c] modifies string [s] in place,
replacing the characters number [start] to [start + len - 1]
by [c].
Raise [Invalid_argument] if [start] and [len] do not
designate a valid substring of [s]. *)
val blit : string -> int -> string -> int -> int -> unit
val blit : string -> pos:int -> to:string -> to_pos:int -> len:int -> unit
(* [String.blit src srcoff dst dstoff len] copies [len] characters
from string [src], starting at character number [srcoff], to
string [dst], starting at character number [dstoff]. It works
@ -66,7 +66,7 @@ val blit : string -> int -> string -> int -> int -> unit
designate a valid substring of [src], or if [dstoff] and [len]
do not designate a valid substring of [dst]. *)
val concat : string -> string list -> string
val concat : sep:string -> string list -> string
(* [String.concat sep sl] catenates the list of strings [sl],
inserting the separator string [sep] between each. *)
@ -75,31 +75,31 @@ val escaped: string -> string
by escape sequences, following the lexical conventions of
Objective Caml. *)
val index: string -> char -> int
val index: string -> elt:char -> int
(* [String.index s c] returns the position of the leftmost
occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *)
val rindex: string -> char -> int
val rindex: string -> elt:char -> int
(* [String.rindex s c] returns the position of the rightmost
occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *)
val index_from: string -> int -> char -> int
val rindex_from: string -> int -> char -> int
val index_from: string -> pos:int -> elt:char -> int
val rindex_from: string -> pos:int -> elt:char -> int
(* Same as [String.index] and [String.rindex], but start
searching at the character position given as second argument.
[String.index s c] is equivalent to [String.index_from s 0 c],
and [String.rindex s c] to
[String.rindex_from s (String.length s - 1) c]. *)
val contains : string -> char -> bool
val contains : string -> elt:char -> bool
(* [String.contains s c] tests if character [c]
appears in the string [s]. *)
val contains_from : string -> int -> char -> bool
val contains_from : string -> pos:int -> elt:char -> bool
(* [String.contains_from s start c] tests if character [c]
appears in the substring of [s] starting from [start] to the end
of [s].
Raise [Invalid_argument] if [start] is not a valid index of [s]. *)
val rcontains_from : string -> int -> char -> bool
val rcontains_from : string -> pos:int -> elt:char -> bool
(* [String.rcontains_from s stop c] tests if character [c]
appears in the substring of [s] starting from the beginning
of [s] to index [stop].
@ -124,7 +124,8 @@ val uncapitalize: string -> string
external unsafe_get : string -> int -> char = "%string_unsafe_get"
external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
external unsafe_blit : string -> int -> string -> int -> int -> unit
= "blit_string" "noalloc"
external unsafe_fill : string -> int -> int -> char -> unit
= "fill_string" "noalloc"
external unsafe_blit :
string -> pos:int -> to:string -> to_pos:int -> len:int -> unit
= "blit_string" "noalloc"
external unsafe_fill : string -> pos:int -> len:int -> char -> unit
= "fill_string" "noalloc"

2
stdlib/sys.mli
View File

@ -23,7 +23,7 @@ external file_exists: string -> bool = "sys_file_exists"
(* Test if a file with the given name exists. *)
external remove: string -> unit = "sys_remove"
(* Remove the given file name from the file system. *)
external rename : string -> string -> unit = "sys_rename"
external rename : old:string -> new:string -> unit = "sys_rename"
(* Rename a file. The first argument is the old name and the
second is the new name. *)
external getenv: string -> string = "sys_getenv"

12
stdlib/weak.mli
View File

@ -22,7 +22,7 @@ type 'a t;;
empty if the object was erased by the GC.
*)
val create : int -> 'a t;;
val create : len:int -> 'a t;;
(* [Weak.create n] returns a new weak array of length [n].
All the pointers are initially empty.
*)
@ -30,30 +30,30 @@ val length : 'a t -> int;;
(* [Weak.length ar] returns the length (number of elements) of
[ar].
*)
val set : 'a t -> int -> 'a option -> unit;;
val set : 'a t -> pos:int -> 'a option -> unit;;
(* [Weak.set ar n (Some el)] sets the [n]th cell of [ar] to be a
(full) pointer to [el]; [Weak.set ar n None] sets the [n]th
cell of [ar] to empty.
Raise [Invalid_argument "Weak.set"] if [n] is not in the range
0 to [Weak.length a - 1].
*)
val get : 'a t -> int -> 'a option;;
val get : 'a t -> pos:int -> 'a option;;
(* [Weak.get ar n] returns None if the [n]th cell of [ar] is
empty, [Some x] (where [x] is the object) if it is full.
Raise [Invalid_argument "Weak.get"] if [n] is not in the range
0 to [Weak.length a - 1].
*)
val check: 'a t -> int -> bool;;
val check: 'a t -> pos:int -> bool;;
(* [Weak.check ar n] returns [true] if the [n]th cell of [ar] is
full, [false] if it is empty. Note that even if [Weak.check ar n]
returns [true], a subsequent [Weak.get ar n] can return [None].
*)
val fill: 'a t -> int -> int -> 'a option -> unit;;
val fill: 'a t -> pos:int -> len:int -> 'a option -> unit;;
(* [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from
[ofs] to [ofs + len - 1]. Raise [Invalid_argument "Weak.fill"]
if [ofs] and [len] do not designate a valid subarray of [a].
*)
val blit : 'a t -> int -> 'a t -> int -> int -> unit;;
val blit : 'a t -> pos:int -> to:'a t -> to_pos:int -> len:int -> unit;;
(* [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers
from [ar1] (starting at [off1]) to [ar2] (starting at [off2]).
It works correctly even if [ar1] and [ar2] are the same.

1
testlabl/dirs Normal file
View File

@ -0,0 +1 @@
asmcomp/linearize.ml asmcomp/spill.ml bytecomp debugger driver lex parsing stdlib testlabl tools toplevel typing utils

1458
testlabl/newlabels.ps Normal file
View File

File diff suppressed because it is too large Load Diff

22
testlabl/tests.ml Normal file
View File

@ -0,0 +1,22 @@
(* $Id$ *)
let f1 = function `a x -> x=1 | `b -> true
let f2 = function `a x -> x | `b -> true
let f3 = function `b -> true
let f x = f1 x && f2 x
let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
String.sub s pos len
let cCAMLtoTKpack_options w = function
`After v1 -> "-after"
| `Anchor v1 -> "-anchor"
| `Before v1 -> "-before"
| `Expand v1 -> "-expand"
| `Fill v1 -> "-fill"
| `In v1 -> "-in"
| `Ipadx v1 -> "-ipadx"
| `Ipady v1 -> "-ipady"
| `Padx v1 -> "-padx"
| `Pady v1 -> "-pady"
| `Side v1 -> "-side"

3
tools/.cvsignore
View File

@ -11,3 +11,6 @@ ocamlmktop
primreq
ocamldumpobj
keywords
ocaml2to3.ml
ocaml2to3

230
tools/ocaml2to3.mll Normal file
View File

@ -0,0 +1,230 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* The lexer definition *)
{
type error =
| Illegal_character
| Unterminated_comment
| Unterminated_string
| Unterminated_string_in_comment
;;
exception Error of error * int * int
(* To store the position of the beginning of a string and comment *)
let string_start_pos = ref 0
and comment_start_pos = ref []
;;
(* Error report *)
let report_error = function
Illegal_character ->
prerr_string "Illegal character"
| Unterminated_comment ->
prerr_string "Comment not terminated"
| Unterminated_string ->
prerr_string "String literal not terminated"
| Unterminated_string_in_comment ->
prerr_string "This comment contains an unterminated string literal"
;;
let modified = ref false ;;
let b = Buffer.create 1024 ;;
}
let blank = [' ' '\010' '\013' '\009' '\012']
let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
let identchar =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
let symbolchar2 =
['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~']
let decimal_literal = ['0'-'9']+
let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
let oct_literal = '0' ['o' 'O'] ['0'-'7']+
let bin_literal = '0' ['b' 'B'] ['0'-'1']+
let float_literal =
['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
rule token = parse
lowercase identchar * ':' [ ^ ':' '=' '>']
{ let s = Lexing.lexeme lexbuf in
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 2;
Buffer.add_string b (String.sub s 0 (String.length s - 2));
Buffer.add_string b " ";
modified := true;
token lexbuf }
| ':' lowercase identchar *
{ let s = Lexing.lexeme lexbuf in
Buffer.add_string b ": ";
Buffer.add_string b (String.sub s 1 (String.length s - 1));
modified := true;
token lexbuf }
| "\""
{ string_start_pos := Lexing.lexeme_start lexbuf;
Buffer.add_string b "\"";
string lexbuf;
token lexbuf }
| "(*"
{ comment_start_pos := [Lexing.lexeme_start lexbuf];
Buffer.add_string b "(*";
comment lexbuf;
token lexbuf }
| "?"
{ Buffer.add_string b "??";
modified := true;
token lexbuf }
| blank +
| "_"
| lowercase identchar *
| uppercase identchar *
| decimal_literal | hex_literal | oct_literal | bin_literal
| float_literal
| "'" [^ '\\' '\''] "'"
| "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
| "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
| "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
| "#"
| "&"
| "&&"
| "`"
| "'"
| "("
| ")"
| "*"
| ","
| "??"
| "->"
| "."
| ".."
| ":"
| "::"
| ":="
| ":>"
| ";"
| ";;"
| "<"
| "<-"
| "="
| "["
| "[|"
| "[<"
| "]"
| "{"
| "{="
| "{<"
| "|"
| "||"
| "|]"
| ">"
| ">]"
| "}"
| ">}"
| "!="
| "-"
| "-."
| ['!' '~'] symbolchar *
| '?' symbolchar2 *
| ['=' '<' '>' '|' '&' '$'] symbolchar *
| ['@' '^'] symbolchar *
| ['+' '-'] symbolchar *
| "**" symbolchar *
| ['*' '/' '%'] symbolchar *
{ Buffer.add_string b (Lexing.lexeme lexbuf);
token lexbuf }
| eof { () }
| _
{ raise (Error(Illegal_character,
Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) }
and comment = parse
"(*"
{ comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
Buffer.add_string b "(*";
comment lexbuf;
}
| "*)"
{ Buffer.add_string b "*)";
match !comment_start_pos with
| [] -> assert false
| [x] -> ()
| _ :: l -> comment_start_pos := l;
comment lexbuf;
}
| "\""
{ string_start_pos := Lexing.lexeme_start lexbuf;
Buffer.add_string b "\"";
begin try string lexbuf
with Error (Unterminated_string, _, _) ->
let st = List.hd !comment_start_pos in
raise (Error (Unterminated_string_in_comment, st, st + 2))
end;
comment lexbuf }
| eof
{ let st = List.hd !comment_start_pos in
raise (Error (Unterminated_comment, st, st + 2));
}
| "''"
| "'" [^ '\\' '\''] "'"
| "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'"
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
| _
{ Buffer.add_string b (Lexing.lexeme lexbuf);
comment lexbuf }
and string = parse
'"'
{ Buffer.add_char b '"' }
| eof
{ raise (Error (Unterminated_string,
!string_start_pos, !string_start_pos+1)) }
| '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
| '\\' ['\\' '"' 'n' 't' 'b' 'r']
| '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
| _
{ Buffer.add_string b (Lexing.lexeme lexbuf);
string lexbuf }
{
let convert_file name =
let ic = open_in name in
Buffer.clear b;
modified := false;
Printexc.catch token (Lexing.from_channel ic);
close_in ic;
if !modified then begin
let backup = name ^ ".orig" in
if Sys.file_exists backup then Sys.remove backup;
Sys.rename name backup;
let oc = open_out name in
Buffer.output_buffer oc b;
close_out oc
end
let _ =
for i = 1 to Array.length Sys.argv - 1 do
let name = Sys.argv.(i) in
prerr_endline name;
Printexc.catch convert_file name
done
}

1
tools/ocamlcp.ml
View File

@ -47,6 +47,7 @@ module Options = Main_args.Make_options (struct
let _intf_suffix s = option_with_arg "-intf-suffix" s
let _linkall = option "-linkall"
let _make_runtime = option "-make-runtime"
let _modern = option "-modern"
let _noassert = option "-noassert"
let _o s = option_with_arg "-o" s
let _output_obj = option "-output-obj"

19
tools/ocamldep.ml
View File

@ -40,12 +40,14 @@ let rec add_type bv ty =
match ty.ptyp_desc with
Ptyp_any -> ()
| Ptyp_var v -> ()
| Ptyp_arrow(t1, t2) -> add_type bv t1; add_type bv t2
| Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
| Ptyp_tuple tl -> List.iter (add_type bv) tl
| Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
| Ptyp_object fl -> List.iter (add_field_type bv) fl
| Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
| Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl
| Ptyp_alias(t, s) -> add_type bv t
| Ptyp_variant(fl, _, _) ->
List.iter (fun (_,_,stl) -> List.iter (add_type bv) stl) fl
and add_field_type bv ft =
match ft.pfield_desc with
@ -75,7 +77,7 @@ let rec add_class_type bv cty =
| Pcty_signature (ty, fieldl) ->
add_type bv ty;
List.iter (add_class_type_field bv) fieldl
| Pcty_fun(ty1, cty2) ->
| Pcty_fun(_, ty1, cty2) ->
add_type bv ty1; add_class_type bv cty2
and add_class_type_field bv = function
@ -102,18 +104,21 @@ let rec add_pattern bv pat =
| Ppat_array pl -> List.iter (add_pattern bv) pl
| Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
| Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
| Ppat_variant(_, op) -> add_opt add_pattern bv op
let rec add_expr bv exp =
match exp.pexp_desc with
Pexp_ident l -> add bv l
| Pexp_constant _ -> ()
| Pexp_let(_, pel, e) -> add_pat_expr_list bv pel; add_expr bv e
| Pexp_function pel -> add_pat_expr_list bv pel
| Pexp_apply(e, el) -> add_expr bv e; List.iter (add_expr bv) el
| Pexp_function (_, _, pel) -> add_pat_expr_list bv pel
| Pexp_apply(e, el) ->
add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
| Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel
| Pexp_tuple el -> List.iter (add_expr bv) el
| Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte
| Pexp_variant(_, opte) -> add_opt add_expr bv opte
| Pexp_record(lblel, opte) ->
List.iter (fun (lbl, e) -> add_expr bv e) lblel;
add_opt add_expr bv opte
@ -228,10 +233,10 @@ and add_class_expr bv ce =
add bv l; List.iter (add_type bv) tyl
| Pcl_structure(pat, fieldl) ->
add_pattern bv pat; List.iter (add_class_field bv) fieldl
| Pcl_fun(pat, ce) ->
| Pcl_fun(_, _, pat, ce) ->
add_pattern bv pat; add_class_expr bv ce
| Pcl_apply(ce, exprl) ->
add_class_expr bv ce; List.iter (add_expr bv) exprl
add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
| Pcl_let(_, pel, ce) ->
add_pat_expr_list bv pel; add_class_expr bv ce
| Pcl_constraint(ce, ct) ->

13
tools/ocamlprof.ml
View File

@ -181,7 +181,7 @@ and rw_exp iflag sexp =
rewrite_patexp_list iflag spat_sexp_list;
rewrite_exp iflag sbody
| Pexp_function caselist ->
| Pexp_function (_, _, caselist) ->
if !instr_fun && not sexp.pexp_loc.loc_ghost then
rewrite_function iflag caselist
else
@ -203,7 +203,7 @@ and rw_exp iflag sexp =
| Pexp_apply(sfunct, sargs) ->
rewrite_exp iflag sfunct;
rewrite_exp_list iflag sargs
rewrite_exp_list iflag (List.map snd sargs)
| Pexp_tuple sexpl ->
rewrite_exp_list iflag sexpl
@ -212,6 +212,10 @@ and rw_exp iflag sexp =
| Pexp_construct(_, Some sarg, _) ->
rewrite_exp iflag sarg
| Pexp_variant(_, None) -> ()
| Pexp_variant(_, Some sarg) ->
rewrite_exp iflag sarg
| Pexp_record(lid_sexp_list, None) ->
rewrite_labelexp_list iflag lid_sexp_list
| Pexp_record(lid_sexp_list, Some sexp) ->
@ -325,10 +329,11 @@ and rewrite_class_expr iflag cexpr =
Pcl_constr _ -> ()
| Pcl_structure (_, fields) ->
List.iter (rewrite_class_field iflag) fields
| Pcl_fun (_, cexpr) ->
| Pcl_fun (_, _, _, cexpr) ->
rewrite_class_expr iflag cexpr
| Pcl_apply (cexpr, exprs) ->
rewrite_class_expr iflag cexpr; List.iter (rewrite_exp iflag) exprs
rewrite_class_expr iflag cexpr;
List.iter (rewrite_exp iflag) (List.map snd exprs)
| Pcl_let (_, spat_sexp_list, cexpr) ->
rewrite_patexp_list iflag spat_sexp_list;
rewrite_class_expr iflag cexpr

27
toplevel/genprintval.ml
View File

@ -176,7 +176,7 @@ module Make(O : OBJ) = struct
match (Ctype.repr ty).desc with
Tvar ->
print_string "<poly>"
| Tarrow(ty1, ty2) ->
| Tarrow(_, ty1, ty2) ->
print_string "<fun>"
| Ttuple(ty_list) ->
if check_depth depth obj ty then begin
@ -319,8 +319,33 @@ module Make(O : OBJ) = struct
| Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
print_string "<unknown constructor>"
end
| Tvariant row ->
let row = Btype.row_repr row in
if O.is_block obj then begin
let tag : int = O.obj (O.field obj 0) in
if prio > 1 then (open_box 2; print_char '(');
print_char '`';
List.iter
(fun (l,f) -> if Btype.hash_variant l = tag then
match Btype.row_field_repr f with
Rpresent(Some ty) ->
print_string l; print_space ();
cautious (print_val 2 (depth - 1) (O.field obj 1)) ty
| _ -> ())
row.row_fields;
if prio >1 then (print_char ')'; close_box ())
end else begin
let tag : int = O.obj obj in
print_char '`';
List.iter
(fun (l,_) ->
if Btype.hash_variant l = tag then print_string l)
row.row_fields
end
| Tobject (_, _) ->
print_string "<obj>"
| Tsubst ty ->
print_val prio (depth - 1) obj ty
| Tfield(_, _, _, _) | Tnil | Tlink _ ->
fatal_error "Printval.print_value"

2
toplevel/topdirs.ml
View File

@ -120,7 +120,7 @@ let find_printer_type lid =
Ctype.begin_def();
let ty_arg = Ctype.newvar() in
Ctype.unify !toplevel_env
(Ctype.newty (Tarrow(ty_arg, Ctype.instance Predef.type_unit)))
(Ctype.newty (Tarrow("", ty_arg, Ctype.instance Predef.type_unit)))
(Ctype.instance desc.val_type);
Ctype.end_def();
Ctype.generalize ty_arg;

1
toplevel/topmain.ml
View File

@ -23,6 +23,7 @@ let main () =
Arg.parse [
"-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
"<dir> Add <dir> to the list of include directories";
"-modern", Arg.Clear classic, " Use strict label syntax";
"-noassert", Arg.Set noassert, " Do not compile assertion checks";
"-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
"-unsafe", Arg.Set fast, " No bound checking on array and string access";

12
toplevel/trace.ml
View File

@ -55,11 +55,17 @@ let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
let invoke_traced_function codeptr env arg =
Meta.invoke_traced_function codeptr env arg
let print_label l =
if l <> "" then begin
print_string l;
print_char ':'
end
(* If a function returns a functional value, wrap it into a trace code *)
let rec instrument_result env name clos_typ =
match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
Tarrow(t1, t2) ->
Tarrow(l, t1, t2) ->
let starred_name =
match name with
Lident s -> Lident(s ^ "*")
@ -71,6 +77,7 @@ let rec instrument_result env name clos_typ =
open_box 2;
Printtyp.longident starred_name;
print_string " <--"; print_space();
print_label l;
print_value !toplevel_env arg t1;
close_box(); print_newline();
try
@ -93,11 +100,12 @@ let rec instrument_result env name clos_typ =
let instrument_closure env name clos_typ =
match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
Tarrow(t1, t2) ->
Tarrow(l, t1, t2) ->
let trace_res = instrument_result env name t2 in
(fun actual_code closure arg ->
open_box 2;
Printtyp.longident name; print_string " <--"; print_space();
print_label l;
print_value !toplevel_env arg t1;
close_box(); print_newline();
try

90
typing/btype.ml
View File

@ -33,11 +33,13 @@ let newty2 level desc =
incr new_id; { desc = desc; level = level; id = !new_id }
let newgenty desc = newty2 generic_level desc
let newgenvar () = newgenty Tvar
(*
let newmarkedvar level =
incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
let newmarkedgenvar () =
incr new_id;
{ desc = Tvar; level = pivot_level - generic_level; id = !new_id }
*)
(**** Representative of a type ****)
@ -60,24 +62,73 @@ let rec repr =
repr t'
| t -> t
let rec row_field_repr = function
Reither(_, _, {contents = Some fi}) -> row_field_repr fi
| fi -> fi
let rec row_repr row =
match (repr row.row_more).desc with
| Tvariant row' ->
let row' = row_repr row' in
{row' with row_fields = row.row_fields @ row'.row_fields}
| _ -> row
let rec row_more row =
match repr row.row_more with
| {desc=Tvariant row'} -> row_more row'
| ty -> ty
let static_row row =
let row = row_repr row in
row.row_closed &&
List.for_all
(fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true)
row.row_fields
let hash_variant s =
let accu = ref 0 in
for i = 0 to String.length s - 1 do
accu := 223 * !accu + Char.code s.[i]
done;
(* reduce to 31 bits *)
accu := !accu land (1 lsl 31 - 1);
(* make it signed for 64 bits architectures *)
if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
(**********************************)
(* Utilities for type traversal *)
(**********************************)
let rec iter_row f row =
List.iter
(fun (_, fi) ->
match row_field_repr fi with
| Rpresent(Some ty) -> f ty
| Reither(_, tl, _) -> List.iter f tl
| _ -> ())
row.row_fields;
match (repr row.row_more).desc with
Tvariant row -> iter_row f row
| Tvar ->
Misc.may (fun (_,l) -> List.iter f l) row.row_name;
List.iter f row.row_bound
| _ -> assert false
let iter_type_expr f ty =
match ty.desc with
Tvar -> ()
| Tarrow (ty1, ty2) -> f ty1; f ty2
| Ttuple l -> List.iter f l
| Tconstr (_, l, _) -> List.iter f l
Tvar -> ()
| Tarrow (_, ty1, ty2)-> f ty1; f ty2
| Ttuple l -> List.iter f l
| Tconstr (_, l, _) -> List.iter f l
| Tobject(ty, {contents = Some (_, p)})
-> f ty; List.iter f p
| Tobject (ty, _) -> f ty
-> f ty; List.iter f p
| Tobject (ty, _) -> f ty
| Tvariant row -> iter_row f row; f (row_more row)
| Tfield (_, _, ty1, ty2) -> f ty1; f ty2
| Tnil -> ()
| Tlink ty -> f ty
| Tnil -> ()
| Tlink ty -> f ty
| Tsubst ty -> assert false; f ty
let saved_desc = ref []
(* Saved association of generic nodes with their description. *)
@ -139,11 +190,10 @@ let rec unmark_class_type =
List.iter unmark_type tyl; unmark_class_type cty
| Tcty_signature sign ->
unmark_class_signature sign
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
unmark_type ty; unmark_class_type cty
(*******************************************)
(* Memorization of abbreviation expansion *)
(*******************************************)
@ -175,3 +225,23 @@ let rec forget_abbrev_rec mem path =
let forget_abbrev mem path =
try mem := forget_abbrev_rec !mem path with Exit -> ()
(**********************************)
(* Utilities for labels *)
(**********************************)
let is_optional l =
String.length l > 0 && l.[0] = '?'
let label_name l =
if is_optional l then String.sub l 1 (String.length l - 1)
else l
let rec extract_label_aux hd l = function
[] -> raise Not_found
| (l',t as p) :: ls ->
if label_name l' = l then (l', t, List.rev hd, ls)
else extract_label_aux (p::hd) l ls
let extract_label l ls = extract_label_aux [] l ls

26
typing/btype.mli
View File

@ -14,6 +14,7 @@
(* Basic operations on core types *)
open Asttypes
open Types
val generic_level: int
@ -24,10 +25,13 @@ val newgenty: type_desc -> type_expr
(* Create a generic type *)
val newgenvar: unit -> type_expr
(* Return a fresh generic variable *)
(* Use Tsubst instead
val newmarkedvar: int -> type_expr
(* Return a fresh marked variable *)
val newmarkedgenvar: unit -> type_expr
(* Return a fresh marked generic variable *)
*)
val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *)
@ -36,10 +40,23 @@ val field_kind_repr: field_kind -> field_kind
(* Return the canonical representative of an object field
kind. *)
val row_repr: row_desc -> row_desc
(* Return the canonical representative of a row description *)
val row_field_repr: row_field -> row_field
(* Return the canonical representative of a row field *)
val row_more: row_desc -> type_expr
(* Return the extension variable of the row *)
val static_row: row_desc -> bool
(* Return whether the row is static or not *)
val hash_variant: label -> int
(* Hash function for variant tags *)
(**** Utilities for type traversal ****)
val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
(* Iteration on types *)
val iter_row: (type_expr -> unit) -> row_desc -> unit
(* Iteration on types in a row *)
val save_desc: type_expr -> type_desc -> unit
(* Save a type description *)
@ -74,3 +91,12 @@ val memorize_abbrev:
val forget_abbrev:
abbrev_memo ref -> Path.t -> unit
(* Remove an abbreviation from the cache *)
(**** Utilities for labels ****)
val is_optional : label -> bool
val label_name : label -> label
val extract_label :
label -> (label * 'a) list ->
label * 'a * (label * 'a) list * (label * 'a) list
(* actual label, value, before list, after list *)

452
typing/ctype.ml
View File

@ -84,6 +84,8 @@ open Btype
exception Unify of (type_expr * type_expr) list
exception Tags of label * label
exception Subtype of
(type_expr * type_expr) list * (type_expr * type_expr) list
@ -137,9 +139,7 @@ let new_global_ty desc = newty2 !global_level desc
let newvar () = newty2 !current_level Tvar
let newvar2 level = newty2 level Tvar
let newmarkedvar = Btype.newmarkedvar
let new_global_var () = newty2 !global_level Tvar
let newmarkedgenvar = Btype.newmarkedgenvar
let newobj fields = newty (Tobject (fields, ref None))
@ -285,7 +285,7 @@ let rec signature_of_class_type =
function
Tcty_constr (_, _, cty) -> signature_of_class_type cty
| Tcty_signature sign -> sign
| Tcty_fun (ty, cty) -> signature_of_class_type cty
| Tcty_fun (_, ty, cty) -> signature_of_class_type cty
let self_type cty =
repr (signature_of_class_type cty).cty_self
@ -294,9 +294,36 @@ let rec class_type_arity =
function
Tcty_constr (_, _, cty) -> class_type_arity cty
| Tcty_signature _ -> 0
| Tcty_fun (_, cty) -> 1 + class_type_arity cty
| Tcty_fun (_, _, cty) -> 1 + class_type_arity cty
(*******************************************)
(* Miscellaneous operations on row types *)
(*******************************************)
let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q)
let merge_row_fields fi1 fi2 =
let rec merge r1 r2 pairs fi1 fi2 =
match fi1, fi2 with
(l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' ->
if l1 = l2 then merge r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else
if l1 < l2 then merge (p1::r1) r2 pairs fi1' fi2 else
merge r1 (p2::r2) pairs fi1 fi2'
| [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs)
| _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs)
in
merge [] [] [] (sort_row_fields fi1) (sort_row_fields fi2)
let rec filter_row_fields erase = function
[] -> []
| (l,f as p)::fi ->
let fi = filter_row_fields erase fi in
match row_field_repr f with
Rabsent -> fi
| Reither(_,_,e) when erase -> e := Some Rabsent; fi
| _ -> p :: fi
(**************************************)
(* Check genericity of type schemes *)
(**************************************)
@ -312,15 +339,12 @@ let rec closed_schema_rec ty =
match ty.desc with
Tvar when level <> generic_level ->
raise Non_closed
| Tobject(f, {contents = Some (_, p)}) ->
closed_schema_rec f;
List.iter closed_schema_rec p
| Tobject(f, _) ->
closed_schema_rec f
| Tfield(_, kind, t1, t2) ->
if field_kind_repr kind = Fpresent then
closed_schema_rec t1;
closed_schema_rec t2
| Tvariant row when static_row row ->
iter_row closed_schema_rec row
| _ ->
iter_type_expr closed_schema_rec ty
end
@ -352,6 +376,8 @@ let rec free_vars_rec real ty =
free_vars_rec false ty
| Tfield (_, _, ty1, ty2) ->
free_vars_rec true ty1; free_vars_rec false ty2
| Tvariant row when static_row row ->
iter_row (free_vars_rec true) row
| _ ->
iter_type_expr (free_vars_rec true) ty
end;
@ -467,6 +493,16 @@ let rec iter_generalize tyl ty =
begin match ty.desc with
Tconstr (_, _, abbrev) ->
generalize_expans tyl !abbrev
| Tvariant row
when (repr row.row_more).level > !current_level || static_row row ->
let row = row_repr row in
let bound =
List.fold_left
(fun acc (_,f) ->
match row_field_repr f with Reither(_,l,_) -> l@acc | _ -> acc)
[] row.row_fields in
let row = {row with row_bound = bound} in
ty.desc <- Tvariant row;
| _ -> ()
end;
iter_type_expr (iter_generalize tyl) ty
@ -609,11 +645,10 @@ let rec find_repr p1 =
Generic nodes are duplicated, while non-generic nodes are left
as-is.
During instantiation, the description of a generic node is first
replaced by a link to a stub ([Tlink (newmarkedvar ())]). Once the
replaced by a link to a stub ([Tsubst (newvar ())]). Once the
copy is made, it replaces the stub.
After instantiation, the description of generic node, which was
stored by [save_desc], must be put back, using [cleanup_types].
Marked on the copy are removed by [unmark].
*)
let abbreviations = ref (ref Mnil)
@ -621,19 +656,20 @@ let abbreviations = ref (ref Mnil)
let rec copy ty =
let ty = repr ty in
if ty.level <> generic_level then
ty
else begin
match ty.desc with
Tsubst ty -> ty
| _ ->
if ty.level <> generic_level then ty else
let desc = ty.desc in
save_desc ty desc;
let t = newmarkedvar !current_level in (* Stub *)
ty.desc <- Tlink t;
let t = newvar() in (* Stub *)
ty.desc <- Tsubst t;
t.desc <-
begin match desc with
Tvar ->
Tvar
| Tarrow (t1, t2) ->
Tarrow (copy t1, copy t2)
| Tarrow (l, t1, t2) ->
Tarrow (l, copy t1, copy t2)
| Ttuple tl ->
Ttuple (List.map copy tl)
| Tconstr (p, tl, _) ->
@ -664,6 +700,39 @@ let rec copy ty =
Some (p, List.map copy tl)
in
Tobject (copy t1, ref name')
| Tvariant row0 ->
let row = row_repr row0 in
let more = repr row.row_more in
(* We must substitute in a subtle way *)
begin match more.desc with
Tsubst ty2 ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
| _ ->
(* We shall really check the level on the row variable *)
if more.level <> generic_level then Tvariant row0 else
(* We create a new copy *)
let fields =
List.map
(fun (l,fi) -> l,
match row_field_repr fi with
Rpresent (Some ty) -> Rpresent(Some(copy ty))
| Reither(c, l, _) -> Reither(c, List.map copy l, ref None)
| fi -> fi)
row.row_fields
and name =
may_map (fun (p,l) -> p, List.map copy l) row.row_name in
let var =
Tvariant { row_fields = fields; row_more = newvar();
row_bound = List.map copy row.row_bound;
row_closed = row.row_closed; row_name = name }
in
(* Remember it for other occurences *)
save_desc more more.desc;
more.desc <- ty.desc;
var
end
| Tfield (label, kind, t1, t2) ->
begin match field_kind_repr kind with
Fpresent ->
@ -677,43 +746,39 @@ let rec copy ty =
Tnil
| Tlink t -> (* Actually unused *)
Tlink (copy t)
| Tsubst _ ->
assert false
end;
t
end
(**** Variants of instantiations ****)
let instance sch =
let ty = copy sch in
cleanup_types ();
unmark_type ty;
ty
let instance_list schl =
let tyl = List.map copy schl in
cleanup_types ();
List.iter unmark_type tyl;
tyl
let instance_constructor cstr =
let ty_res = copy cstr.cstr_res in
let ty_args = List.map copy cstr.cstr_args in
cleanup_types ();
List.iter unmark_type ty_args; unmark_type ty_res;
(ty_args, ty_res)
let instance_label lbl =
let ty_res = copy lbl.lbl_res in
let ty_arg = copy lbl.lbl_arg in
cleanup_types ();
unmark_type ty_arg; unmark_type ty_res;
(ty_arg, ty_res)
let instance_parameterized_type sch_args sch =
let ty_args = List.map copy sch_args in
let ty = copy sch in
cleanup_types ();
List.iter unmark_type ty_args; unmark_type ty;
(ty_args, ty)
let instance_parameterized_type_2 sch_args sch_lst sch =
@ -721,8 +786,6 @@ let instance_parameterized_type_2 sch_args sch_lst sch =
let ty_lst = List.map copy sch_lst in
let ty = copy sch in
cleanup_types ();
List.iter unmark_type ty_args; List.iter unmark_type ty_lst;
unmark_type ty;
(ty_args, ty_lst, ty)
let instance_class params cty =
@ -736,25 +799,12 @@ let instance_class params cty =
cty_vars =
Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
cty_concr = sign.cty_concr}
| Tcty_fun (ty, cty) ->
Tcty_fun (copy ty, copy_class_type cty)
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, copy ty, copy_class_type cty)
in
let params' = List.map copy params in
let cty' = copy_class_type cty in
cleanup_types ();
let rec unmark_class_type =
function
Tcty_constr (path, tyl, cty) ->
List.iter unmark_type tyl;
unmark_class_type cty
| Tcty_signature sign ->
unmark_type sign.cty_self;
Vars.iter (fun lab (mut, ty) -> unmark_type ty) sign.cty_vars;
| Tcty_fun (ty, cty) ->
unmark_type ty; unmark_class_type cty
in
List.iter unmark_type params';
unmark_class_type cty';
(params', cty')
(**** Instantiation with parameter substitution ****)
@ -865,7 +915,14 @@ let expand_abbrev env ty =
try Env.find_type_expansion path env with Not_found ->
raise Cannot_expand
in
subst env level abbrev (Some ty) params args body
let ty' = subst env level abbrev (Some ty) params args body in
(* Hack to name the variant type *)
begin match repr ty' with
{desc=Tvariant row} as ty when static_row row ->
ty.desc <- Tvariant { row with row_name = Some (path, args) }
| _ -> ()
end;
ty'
end
| _ ->
assert false
@ -949,7 +1006,7 @@ let rec non_recursive_abbrev env ty =
with Cannot_expand ->
iter_type_expr (non_recursive_abbrev env) ty
end
| Tobject (_, _) ->
| Tobject _ | Tvariant _ ->
()
| _ ->
iter_type_expr (non_recursive_abbrev env) ty
@ -984,7 +1041,7 @@ let rec occur_rec env visited ty0 ty =
with Cannot_expand ->
raise Occur
end
| Tobject _ ->
| Tobject _ | Tvariant _ ->
()
| _ ->
iter_type_expr (occur_rec env visited ty0) ty
@ -1120,7 +1177,8 @@ and unify3 env t1 t1' t2 t2' =
update_level env t2'.level t1;
t2'.desc <- Tlink t1
end
| (Tarrow (t1, u1), Tarrow (t2, u2)) ->
| (Tarrow (l1, t1, u1), Tarrow (l2, t2, u2)) when l1 = l2
or !Clflags.classic && not (is_optional l1 or is_optional l2) ->
unify env t1 t2; unify env u1 u2
| (Ttuple tl1, Ttuple tl2) ->
unify_list env tl1 tl2
@ -1139,6 +1197,8 @@ and unify3 env t1 t1' t2 t2' =
| _ ->
()
end
| (Tvariant row1, Tvariant row2) ->
unify_row env row1 row2
| (Tfield _, Tfield _) -> (* Actually unused *)
unify_fields env t1' t2'
| (Tnil, Tnil) ->
@ -1216,6 +1276,85 @@ and unify_kind k1 k2 =
| (Fpresent, Fpresent) -> ()
| _ -> assert false
and unify_row env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
let rm1 = row_more row1 and rm2 =row_more row2 in
if rm1 == rm2 then () else
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
ignore (List.fold_left
(fun hl l ->
let h = hash_variant l in
try raise(Tags(l,List.assoc h hl))
with Not_found -> (h,l)::hl)
(List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
(List.map fst r2));
let more = newty2 (min rm1.level rm2.level) Tvar
and closed = row1.row_closed || row2.row_closed in
let keep switch =
List.for_all
(fun (_,f1,f2) ->
let f1, f2 = switch f1 f2 in
row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
pairs
in
let name =
if r1 = [] && row2.row_name <> None && keep (fun f1 f2 -> f2, f1)
then row2.row_name
else if r2 = [] && row1.row_name <> None && keep (fun f1 f2 -> f1, f2)
then row1.row_name else None
in
let bound = row1.row_bound @ row2.row_bound in
let row0 = {row_fields = []; row_more = more; row_bound = bound;
row_closed = closed; row_name = name} in
let more row rest =
let rest =
if closed then filter_row_fields row.row_closed rest else rest in
if rest <> [] && row.row_closed then raise (Unify []);
let ty =
newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
update_level env (repr row.row_more).level ty;
ty
in
let md1 = rm1.desc and md2 = rm2.desc in
begin try
rm1.desc <- Tlink (more row1 r2);
rm2.desc <- Tlink (more row2 r1);
List.iter
(fun (l,f1,f2) ->
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 == f2 then () else
match f1, f2 with
Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
| Rpresent None, Rpresent None -> ()
| Reither(c1, tl1, e1), Reither(c2, tl2, e2) ->
if e1 == e2 then () else
let tl = tl1 @ tl2 in
let tl =
List.fold_right
(fun t tl ->
let t = repr t in if List.memq t tl then tl else t::tl)
tl [] in
let f = Reither(c1 or c2, tl, ref None) in
e1 := Some f; e2 := Some f
| Reither(false, tl, e1), Rpresent(Some t2) ->
e1 := Some f2;
(try List.iter (fun t1 -> unify env t1 t2) tl
with exn -> e1 := None; raise exn)
| Rpresent(Some t1), Reither(false, tl, e2) ->
e2 := Some f1;
(try List.iter (unify env t1) tl
with exn -> e2 := None; raise exn)
| Reither(true, [], e1), Rpresent None -> e1 := Some f2
| Rpresent None, Reither(true, [], e2) -> e2 := Some f1
| Reither(_, _, e1), Rabsent -> e1 := Some f2
| Rabsent, Reither(_, _, e2) -> e2 := Some f1
| Rabsent, Rabsent -> ()
| _ -> raise (Unify []))
pairs
with exn ->
rm1.desc <- md1; rm2.desc <- md2; raise exn
end
let unify env ty1 ty2 =
try
unify env ty1 ty2
@ -1226,17 +1365,23 @@ let _ = unify' := unify
(**** Special cases of unification ****)
(* Unify [t] and ['a -> 'b]. Return ['a] and ['b]. *)
let rec filter_arrow env t =
(*
Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
In modern mode, label mismatch is accepted when
(1) the requested label is ""
(2) the original label is not optional
*)
let rec filter_arrow env t l =
let t = expand_head env t in
match t.desc with
Tvar ->
let t1 = newvar () and t2 = newvar () in
let t' = newty (Tarrow (t1, t2)) in
let t' = newty (Tarrow (l, t1, t2)) in
update_level env t.level t';
t.desc <- Tlink t';
(t1, t2)
| Tarrow(t1, t2) ->
| Tarrow(l', t1, t2)
when l = l' || !Clflags.classic && l = "" && not (is_optional l') ->
(t1, t2)
| _ ->
raise (Unify [])
@ -1310,7 +1455,11 @@ let moregen_occur env level ty =
if ty.level > level then begin
if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
ty.level <- pivot_level - ty.level;
iter_type_expr occur ty
match ty.desc with
Tvariant row when static_row row ->
iter_row occur row
| _ ->
iter_type_expr occur ty
end
in
begin try
@ -1349,7 +1498,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
else t1'.level = generic_level ->
moregen_occur env t1'.level t2;
t1'.desc <- Tlink t2
| (Tarrow (t1, u1), Tarrow (t2, u2)) ->
| (Tarrow (l1, t1, u1), Tarrow (l2, t2, u2)) when l1 = l2
or !Clflags.classic && not (is_optional l1 or is_optional l2) ->
moregen inst_nongen type_pairs env t1 t2;
moregen inst_nongen type_pairs env u1 u2
| (Ttuple tl1, Ttuple tl2) ->
@ -1357,6 +1507,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
| (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
when Path.same p1 p2 ->
moregen_list inst_nongen type_pairs env tl1 tl2
| (Tvariant row1, Tvariant row2) ->
moregen_row inst_nongen type_pairs env row1 row2
| (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
moregen_fields inst_nongen type_pairs env fi1 fi2
| (Tfield _, Tfield _) -> (* Actually unused *)
@ -1403,6 +1555,52 @@ and moregen_kind k1 k2 =
| (Fpresent, Fpresent) -> ()
| _ -> raise (Unify [])
and moregen_row inst_nongen type_pairs env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
let r1, r2 =
if row2.row_closed then
filter_row_fields true r1, filter_row_fields false r2
else r1, r2
in
if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
then raise (Unify []);
let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
let ext =
if not (static_row row2) then moregen_occur env rm1.level rm2;
if r2 = [] then rm2 else
let ty = newty2 generic_level (Tvariant{row2 with row_fields = r2}) in
moregen_occur env rm1.level ty;
ty
in
if ext != rm1 then rm1.desc <- Tlink ext;
List.iter
(fun (l,f1,f2) ->
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 == f2 then () else
match f1, f2 with
Rpresent(Some t1), Rpresent(Some t2) ->
moregen inst_nongen type_pairs env t1 t2
| Rpresent None, Rpresent None -> ()
| Reither(false, tl1, e1), Rpresent(Some t2) ->
e1 := Some f2;
List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
| Reither(c1, tl1, e1), Reither(c2, tl2, e2) ->
if c1 && not c2 then raise(Unify []);
e1 := Some f2;
begin match tl2 with
[t2] when tl1 <> [] -> List.iter
(fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
| _ ->
if List.length tl1 <> List.length tl2 then raise (Unify []);
List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
end
| Reither(true, [], e1), Rpresent None -> e1 := Some f2
| Reither(_, _, e1), Rabsent -> e1 := Some f2
| Rabsent, Rabsent -> ()
| _ -> raise (Unify []))
pairs
(*
Non-generic variable can be instanciated only if [inst_nongen] is
true. So, [inst_nongen] should be set to false if the subject might
@ -1470,7 +1668,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
with Not_found ->
subst := (t1', t2') :: !subst
end
| (Tarrow (t1, u1), Tarrow (t2, u2)) ->
| (Tarrow (l1, t1, u1), Tarrow (l2, t2, u2)) when l1 = l2
or !Clflags.classic && not (is_optional l1 or is_optional l2) ->
eqtype rename type_pairs subst env t1 t2;
eqtype rename type_pairs subst env u1 u2;
| (Ttuple tl1, Ttuple tl2) ->
@ -1478,6 +1677,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
| (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
when Path.same p1 p2 ->
eqtype_list rename type_pairs subst env tl1 tl2
| (Tvariant row1, Tvariant row2) ->
eqtype_row rename type_pairs subst env row1 row2
| (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
eqtype_fields rename type_pairs subst env fi1 fi2
| (Tfield _, Tfield _) -> (* Actually unused *)
@ -1523,6 +1724,28 @@ and eqtype_kind k1 k2 =
| (Fpresent, Fpresent) -> ()
| _ -> raise (Unify [])
and eqtype_row rename type_pairs subst env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
if row1.row_closed <> row2.row_closed
|| not row1.row_closed && (r1 <> [] || r2 <> [])
|| filter_row_fields false (r1 @ r2) <> []
then raise (Unify []);
eqtype rename type_pairs subst env row1.row_more row2.row_more;
List.iter
(fun (_,f1,f2) ->
match row_field_repr f1, row_field_repr f2 with
Rpresent(Some t1), Rpresent(Some t2) ->
eqtype rename type_pairs subst env t1 t2
| Reither(c1, tl1,_), Reither(c2, tl2,_)
when c1 = c2 && List.length tl1 = List.length tl2 ->
List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
| Rpresent None, Rpresent None -> ()
| Rabsent, Rabsent -> ()
| _ -> raise (Unify []))
pairs
(* Two modes: with or without renaming of variables *)
let equal env rename tyl1 tyl2 =
try
@ -1562,7 +1785,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
moregen_clty true type_pairs env cty1 cty2
| _, Tcty_constr (_, _, cty2) ->
moregen_clty true type_pairs env cty1 cty2
| Tcty_fun (ty1, cty1'), Tcty_fun (ty2, cty2') ->
| Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
end;
@ -1687,7 +1910,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
equal_clty true type_pairs subst env cty1 cty2
| _, Tcty_constr (_, _, cty2) ->
equal_clty true type_pairs subst env cty1 cty2
| Tcty_fun (ty1, cty1'), Tcty_fun (ty2, cty2') ->
| Tcty_fun (l1, ty1, cty1'), Tcty_fun (l2, ty2, cty2') when l1 = l2 ->
begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
raise (Failure [CM_Parameter_mismatch (expand_trace env trace)])
end;
@ -1824,11 +2047,11 @@ let rec build_subtype env visited t =
build_subtype env visited t'
| Tvar ->
(t, false)
| Tarrow(t1, t2) ->
| Tarrow(l, t1, t2) ->
if List.memq t visited then (t, false) else
let (t1', c1) = (t1, false) in
let (t2', c2) = build_subtype env (t::visited) t2 in
if c1 or c2 then (newty (Tarrow(t1', t2')), true)
if c1 or c2 then (newty (Tarrow(l, t1', t2')), true)
else (t, false)
| Ttuple tlist ->
if List.memq t visited then (t, false) else
@ -1845,6 +2068,26 @@ let rec build_subtype env visited t =
else (t, false)
| Tconstr(p, tl, abbrev) ->
(t, false)
| Tvariant row ->
let row = row_repr row in
if not (static_row row) then (t, false) else
let bound = ref row.row_bound in
let fields =
List.map
(fun (l,f) -> l, match row_field_repr f with
Rpresent None ->
Reither(true, [], ref None)
| Rpresent(Some t) ->
bound := t :: !bound;
Reither(false, [t], ref None)
| _ -> assert false)
(filter_row_fields false row.row_fields)
in
if fields = [] then (t, false) else
let row =
{row with row_fields = fields; row_more = newvar(); row_bound = !bound}
in
(newty (Tvariant row), true)
| Tobject (t1, _) when opened_object t1 ->
(t, false)
| Tobject (t1, _) ->
@ -1865,6 +2108,8 @@ let rec build_subtype env visited t =
| Tnil ->
let v = newvar () in
(v, true)
| Tsubst _ ->
assert false
let enlarge_type env ty =
subtypes := [];
@ -1906,7 +2151,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
match (t1.desc, t2.desc) with
(Tvar, _) | (_, Tvar) ->
(trace, t1, t2)::cstrs
| (Tarrow(t1, u1), Tarrow(t2, u2)) ->
| (Tarrow(l1, t1, u1), Tarrow(l2, t2, u2)) when l1 = l2
or !Clflags.classic && not (is_optional l1 or is_optional l2) ->
let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in
subtype_rec env ((u1, u2)::trace) u1 u2 cstrs
| (Ttuple tl1, Ttuple tl2) ->
@ -1923,6 +2169,28 @@ let rec subtype_rec env trace t1 t2 cstrs =
(trace, t1, t2)::cstrs
| (Tobject (f1, _), Tobject (f2, _)) ->
subtype_fields env trace f1 f2 cstrs
| (Tvariant row1, Tvariant row2) ->
let row1 = row_repr row1 and row2 = row_repr row2 in
begin try
if not row1.row_closed then raise Exit;
let r1, r2, pairs =
merge_row_fields row1.row_fields row2.row_fields in
if filter_row_fields false r1 <> [] then raise Exit;
List.fold_left
(fun cstrs (_,f1,f2) ->
match row_field_repr f1, row_field_repr f2 with
(Rpresent None|Reither(true,_,_)), Rpresent None ->
cstrs
| Rpresent(Some t1), Rpresent(Some t2) ->
subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
| Reither(false, t1::_, _), Rpresent(Some t2) ->
subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
| Rabsent, _ -> cstrs
| _ -> raise Exit)
cstrs pairs
with Exit ->
(trace, t1, t2)::cstrs
end
| (_, _) ->
(trace, t1, t2)::cstrs
end
@ -1992,7 +2260,7 @@ let unroll_abbrev id tl ty =
(* Return the arity (as for curried functions) of the given type. *)
let rec arity ty =
match (repr ty).desc with
Tarrow(t1, t2) -> 1 + arity t2
Tarrow(_, t1, t2) -> 1 + arity t2
| _ -> 0
(* Check whether an abbreviation expands to itself. *)
@ -2020,29 +2288,28 @@ let rec cyclic_abbrev env id ty =
Variables are left unchanged. Other type nodes are duplicated, with
levels set to generic level.
During copying, the description of a (non-variable) node is first
replaced by a link to a marked stub ([Tlink (newmarkedgenvar ())]).
The mark allows to differentiate the original type from the copy.
replaced by a link to a stub ([Tsubst (newgenvar ())]).
Once the copy is made, it replaces the stub.
After copying, the description of node, which was stored by
[save_desc], must be put back, using [cleanup_types], and the
marks on the copy must be removed.
[save_desc], must be put back, using [cleanup_types].
*)
let rec nondep_type_rec env id ty =
let ty = repr ty in
if (ty.desc = Tvar) || (ty.level < lowest_level) then
ty
else begin
match ty.desc with
Tvar -> ty
| Tsubst ty -> ty
| _ ->
let desc = ty.desc in
save_desc ty desc;
let ty' = newmarkedgenvar () in (* Stub *)
ty.desc <- Tlink ty';
let ty' = newgenvar () in (* Stub *)
ty.desc <- Tsubst ty';
ty'.desc <-
begin match desc with
Tvar ->
fatal_error "Ctype.nondep_type_rec"
| Tarrow(t1, t2) ->
Tarrow(nondep_type_rec env id t1, nondep_type_rec env id t2)
| Tarrow(l, t1, t2) ->
Tarrow(l, nondep_type_rec env id t1, nondep_type_rec env id t2)
| Ttuple tl ->
Ttuple(List.map (nondep_type_rec env id) tl)
| Tconstr(p, tl, abbrev) ->
@ -2068,6 +2335,46 @@ let rec nondep_type_rec env id ty =
| Some (p, tl) ->
if Path.isfree id p then None
else Some (p, List.map (nondep_type_rec env id) tl)))
| Tvariant row ->
let row = row_repr row in
let more = repr row.row_more in
(* We must substitute in a subtle way *)
begin match more.desc with
Tsubst ty2 ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
| _ ->
(* We create a new copy *)
let bound = ref [] in
let fields =
List.map
(fun (l,fi) -> l,
match row_field_repr fi with
Rpresent (Some ty) ->
Rpresent(Some (nondep_type_rec env id ty))
| Reither(c, l, _) ->
let l = List.map (nondep_type_rec env id) l in
bound := l @ !bound;
Reither(c, l, ref None)
| fi -> fi)
row.row_fields
and name =
match row.row_name with
Some (p,l) when Path.isfree id p ->
Some (p, List.map (nondep_type_rec env id) l)
| _ -> None
in
let var =
Tvariant { row_fields = fields; row_more = newgenvar();
row_bound = !bound;
row_closed = row.row_closed; row_name = name }
in
(* Remember it for other occurences *)
save_desc more more.desc;
more.desc <- ty.desc;
var
end
| Tfield(label, kind, t1, t2) ->
begin match field_kind_repr kind with
Fpresent ->
@ -2083,9 +2390,10 @@ let rec nondep_type_rec env id ty =
Tnil
| Tlink ty -> (* Actually unused *)
Tlink(nondep_type_rec env id ty)
| Tsubst _ ->
assert false
end;
ty'
end
let nondep_type env id ty =
try
@ -2165,8 +2473,8 @@ let rec nondep_class_type env id =
nondep_class_type env id cty)
| Tcty_signature sign ->
Tcty_signature (nondep_class_signature env id sign)
| Tcty_fun (ty, cty) ->
Tcty_fun (nondep_type_rec env id ty, nondep_class_type env id cty)
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty)
let nondep_class_declaration env id decl =
assert (not (Path.isfree id decl.cty_path));

13
typing/ctype.mli
View File

@ -18,6 +18,7 @@ open Asttypes
open Types
exception Unify of (type_expr * type_expr) list
exception Tags of label * label
exception Subtype of
(type_expr * type_expr) list * (type_expr * type_expr) list
exception Cannot_expand
@ -70,6 +71,14 @@ val set_object_name:
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
val sort_row_fields: (label * row_field) list -> (label * row_field) list
val merge_row_fields:
(label * row_field) list -> (label * row_field) list ->
(label * row_field) list * (label * row_field) list *
(label * row_field * row_field) list
val filter_row_fields:
bool -> (label * row_field) list -> (label * row_field) list
val generalize: type_expr -> unit
(* Generalize in-place the given type *)
val iterative_generalization: int -> type_expr list -> type_expr list
@ -111,8 +120,8 @@ val enforce_constraints: Env.t -> type_expr -> unit
val unify: Env.t -> type_expr -> type_expr -> unit
(* Unify the two types given. Raise [Unify] if not possible. *)
val filter_arrow: Env.t -> type_expr -> type_expr * type_expr
(* A special case of unification (with 'a -> 'b). *)
val filter_arrow: Env.t -> type_expr -> label -> type_expr * type_expr
(* A special case of unification (with l:'a -> 'b). *)
val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
(* A special case of unification (with {m : 'a; 'b}). *)
val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit

15
typing/env.ml
View File

@ -97,6 +97,8 @@ type pers_struct =
let persistent_structures =
(Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
let components_of_module' = ref (fun _ _ _ _ -> assert false)
let read_pers_struct modname filename =
let ic = open_in_bin filename in
try
@ -106,9 +108,12 @@ let read_pers_struct modname filename =
close_in ic;
raise(Error(Not_an_interface filename))
end;
let (name, sign, comps) = input_value ic in
let (name, sign) = input_value ic in
let crcs = input_value ic in
close_in ic;
let comps =
!components_of_module' empty Subst.identity
(Pident(Ident.create_persistent name)) (Tmty_signature sign) in
let ps = { ps_name = name;
ps_sig = sign;
ps_comps = comps;
@ -463,7 +468,7 @@ let rec components_of_module env sub path mty =
let decl' = Subst.modtype_declaration sub decl in
c.comp_modtypes <-
Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
env := store_modtype id path decl' !env
env := store_modtype id path decl !env
| Tsig_class(id, decl) ->
let decl' = Subst.class_declaration sub decl in
c.comp_classes <-
@ -599,6 +604,8 @@ and store_cltype id path desc env =
cltypes = Ident.add id (path, desc) env.cltypes;
summary = Env_cltype(env.summary, id, desc) }
let _ = components_of_module' := components_of_module
(* Memoized function to compute the components of a functor application
in a path. *)
@ -751,10 +758,10 @@ let save_signature sg modname filename =
Btype.cleanup_abbrev ();
let comps =
components_of_module empty Subst.identity
(Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
(Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
let oc = open_out_bin filename in
output_string oc cmi_magic_number;
output_value oc (modname, sg, comps);
output_value oc (modname, sg);
flush oc;
let crc = Digest.file filename in
let crcs = (modname, crc) :: imported_units() in

129
typing/parmatch.ml
View File

@ -71,6 +71,8 @@ let simple_match p1 p2 =
match p1.pat_desc, p2.pat_desc with
| Tpat_construct(c1, _), Tpat_construct(c2, _) ->
c1.cstr_tag = c2.cstr_tag
| Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
l1 = l2
| Tpat_constant(Const_float s1), Tpat_constant(Const_float s2) ->
float_of_string s1 = float_of_string s2
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
@ -118,12 +120,14 @@ let sort_record p = match p.pat_desc with
let simple_match_args p1 p2 =
match p2.pat_desc with
Tpat_construct(cstr, args) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
| Tpat_record(args) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
Tpat_construct(_, args) -> omega_list args
| Tpat_variant(_, Some _, _) -> [omega]
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args) -> omega_list args
| Tpat_array(args) -> omega_list args
@ -144,6 +148,9 @@ let rec normalize_pat q = match q.pat_desc with
make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
| Tpat_construct (c,args) ->
make_pat (Tpat_construct (c,omega_list args)) q.pat_type q.pat_env
| Tpat_variant (l, arg, row) ->
make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
q.pat_type q.pat_env
| Tpat_array (args) ->
make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env
| Tpat_record (largs) ->
@ -217,6 +224,16 @@ let set_args q r = match q with
make_pat
(Tpat_construct (c,args)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
let arg, rest =
match omega, r with
Some _, a::r -> Some a, r
| None, r -> None, r
| _ -> assert false
in
make_pat
(Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_array omegas} ->
let args,rest = read_args omegas r in
make_pat
@ -317,11 +334,53 @@ let filter_all pat0 pss =
not.
*)
let full_match env = match env with
let full_match tdefs force env = match env with
| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ ->
false
| ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
List.length env = c.cstr_consts + c.cstr_nonconsts
| ({pat_desc = Tpat_variant(c,_,row); pat_type = ty},_) :: _ ->
let fields =
List.map
(function ({pat_desc = Tpat_variant (tag, _, row)}, _) ->
(* You must get a tag's type inside its own row *)
tag, List.assoc tag (Btype.row_repr row).row_fields
| _ -> assert false)
env
in
let row = Btype.row_repr row in
if force then begin
if not row.row_closed then begin
let more_fields =
List.fold_left
(fun acc (tag, f) ->
if List.mem_assoc tag acc || List.mem_assoc tag row.row_fields
then acc
else (tag, f)::acc)
[] fields
in
let closed = { row_fields = more_fields; row_more = Ctype.newvar();
row_bound = row.row_bound; row_closed = true;
row_name = None }
(* Cannot fail *)
in Ctype.unify tdefs row.row_more (Btype.newgenty (Tvariant closed))
end;
List.fold_left
(fun ok (tag,f) ->
match Btype.row_field_repr f with
Rabsent -> ok
| Reither(_, _, e) ->
if not (List.mem_assoc tag fields) then e := Some Rabsent;
ok
| Rpresent _ ->
ok && List.mem_assoc tag fields)
true row.row_fields
end else
row.row_closed &&
List.for_all
(fun (tag,f) ->
Btype.row_field_repr f = Rabsent || List.mem_assoc tag fields)
row.row_fields
| ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
List.length env = 256
| ({pat_desc = Tpat_constant(_)},_) :: _ -> false
@ -400,6 +459,30 @@ let build_other env = match env with
with
| Datarepr.Constr_not_found -> omega
end
| ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ ->
let tags =
List.map
(function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag
| _ -> assert false)
env
in
let row = Btype.row_repr row in
let make_other_pat tag const =
let arg = if const then None else Some omega in
make_pat (Tpat_variant(tag, arg, row)) p.pat_type p.pat_env in
begin match
List.fold_left
(fun others (tag,f) -> match Btype.row_field_repr f with
Rabsent | Reither _ -> others
| Rpresent arg -> make_other_pat tag (arg = None) :: others)
[] row.row_fields
with [] -> assert false
| pat::other_pats ->
List.fold_left
(fun p_res pat ->
make_pat (Tpat_or (pat, p_res)) p.pat_type p.pat_env)
pat other_pats
end
| ({pat_desc = Tpat_constant(Const_char _)} as p,_) :: _ ->
let all_chars =
List.map
@ -506,36 +589,38 @@ let rec try_many f = function
| r -> r
end
let rec satisfiable build pss qs =
let rec satisfiable tdefs build pss qs =
match pss with
[] -> if build then Rsome qs else Rok (* qs is a matching vector *)
| _ ->
match qs with
[] -> Rnone
| {pat_desc = Tpat_or(q1,q2)}::qs ->
begin match satisfiable build pss (q1::qs) with
| Rnone -> satisfiable build pss (q2::qs)
begin match satisfiable tdefs build pss (q1::qs) with
| Rnone -> satisfiable tdefs build pss (q2::qs)
| r -> r
end
| {pat_desc = Tpat_alias(q,_)}::qs ->
satisfiable build pss (q::qs)
satisfiable tdefs build pss (q::qs)
| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
let q0 = discr_pat omega pss in
begin match filter_all q0 pss with
(* first column of pss is made of variables only *)
[] -> begin match satisfiable build (filter_extra pss) qs with
[] -> begin match satisfiable tdefs build (filter_extra pss) qs with
| Rsome r -> Rsome (q0::r)
| r -> r
end
| constrs ->
let try_non_omega (p,pss) =
match satisfiable build pss (simple_match_args p omega @ qs) with
match
satisfiable tdefs build pss (simple_match_args p omega @ qs)
with
| Rsome r -> Rsome (set_args p r)
| r -> r in
if full_match constrs
if full_match tdefs build constrs
then try_many try_non_omega constrs
else
match satisfiable build (filter_extra pss) qs with
match satisfiable tdefs build (filter_extra pss) qs with
| Rnone -> try_many try_non_omega constrs
| Rok -> Rok
| Rsome r -> Rsome (build_other constrs::r)
@ -543,7 +628,8 @@ let rec satisfiable build pss qs =
| q::qs ->
let q0 = discr_pat q pss in
match
satisfiable build (filter_one q0 pss) (simple_match_args q0 q @ qs)
satisfiable tdefs build (filter_one q0 pss)
(simple_match_args q0 q @ qs)
with
| Rsome r -> Rsome (set_args q0 r)
| r -> r
@ -577,6 +663,9 @@ let rec le_pat p q =
| Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
| Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
l1 = l2 & le_pat p1 p2
| Tpat_variant(l1,None,_), Tpat_variant(l2,None,_) -> l1 = l2
| Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
| Tpat_record l1, Tpat_record l2 ->
let ps = List.map (fun (_,p) -> p) l1
@ -647,6 +736,10 @@ let rec pretty_val ppf v = match v.pat_desc with
| _ ->
fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
end
| Tpat_variant (l, None, _) ->
fprintf ppf "`%s" l
| Tpat_variant (l, Some w, _) ->
fprintf ppf "@[<2`%s@ %a@]" l pretty_arg w
| Tpat_record lvs ->
fprintf ppf "@[{%a}@]"
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
@ -706,18 +799,19 @@ let top_pretty ppf v =
(* - Unused match case *)
(******************************)
let check_partial loc casel =
let check_partial tdefs loc casel =
let pss = get_mins (initial_matrix casel) in
let r = match pss with
| [] -> begin match casel with
| [] -> Rnone
| (p,_) :: _ -> Rsome [p]
end
| ps::_ -> satisfiable true pss (omega_list ps) in
| ps::_ -> satisfiable tdefs true pss (omega_list ps) in
match r with
| Rnone -> ()
| Rnone -> Total
| Rok ->
Location.print_warning loc (Warnings.Partial_match "")
Location.print_warning loc (Warnings.Partial_match "");
Partial
| Rsome [v] ->
let errmsg =
try
@ -727,7 +821,8 @@ let check_partial loc casel =
Buffer.contents buf
with _ ->
"" in
Location.print_warning loc (Warnings.Partial_match errmsg)
Location.print_warning loc (Warnings.Partial_match errmsg);
Partial
| _ ->
fatal_error "Parmatch.check_partial"
@ -735,7 +830,7 @@ let location_of_clause = function
pat :: _ -> pat.pat_loc
| _ -> fatal_error "Parmatch.location_of_clause"
let check_unused casel =
let check_unused tdefs casel =
let prefs =
List.fold_right
(fun (pat,act as clause) r ->
@ -748,7 +843,7 @@ let check_unused casel =
(fun (pss, ((qs, _) as clause)) ->
try
if
(match satisfiable false pss qs with
(match satisfiable tdefs false pss qs with
| Rnone -> true
| Rok -> false
| _ -> assert false)

5
typing/parmatch.mli
View File

@ -16,5 +16,6 @@
open Typedtree
val check_partial: Location.t -> (pattern * expression) list -> unit
val check_unused: (pattern * expression) list -> unit
val check_partial:
Env.t -> Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit

15
typing/predef.ml
View File

@ -28,6 +28,7 @@ and ident_exn = Ident.create "exn"
and ident_array = Ident.create "array"
and ident_list = Ident.create "list"
and ident_format = Ident.create "format"
and ident_option = Ident.create "option"
let path_int = Pident ident_int
and path_char = Pident ident_char
@ -39,6 +40,7 @@ and path_exn = Pident ident_exn
and path_array = Pident ident_array
and path_list = Pident ident_list
and path_format = Pident ident_format
and path_option = Pident ident_option
let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
@ -49,6 +51,7 @@ and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
let ident_match_failure = Ident.create "Match_failure"
and ident_out_of_memory = Ident.create "Out_of_memory"
@ -100,7 +103,14 @@ let build_initial_env add_type add_exception empty_env =
{type_params = [newgenvar(); newgenvar(); newgenvar()];
type_arity = 3;
type_kind = Type_abstract;
type_manifest = None} in
type_manifest = None}
and decl_option =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = Type_variant["None", []; "Some", [tvar]];
type_manifest = None}
in
add_exception ident_match_failure
[newgenty (Ttuple[type_string; type_int; type_int])] (
@ -113,6 +123,7 @@ let build_initial_env add_type add_exception empty_env =
add_exception ident_sys_error [type_string] (
add_exception ident_end_of_file [] (
add_exception ident_division_by_zero [] (
add_type ident_option decl_option (
add_type ident_format decl_format (
add_type ident_list decl_list (
add_type ident_array decl_array (
@ -123,7 +134,7 @@ let build_initial_env add_type add_exception empty_env =
add_type ident_string decl_abstr (
add_type ident_char decl_abstr (
add_type ident_int decl_abstr (
empty_env))))))))))))))))))))
empty_env)))))))))))))))))))))
let builtin_values =
List.map (fun id -> Ident.make_global id; (Ident.name id, id))

2
typing/predef.mli
View File

@ -25,6 +25,7 @@ val type_unit: type_expr
val type_exn: type_expr
val type_array: type_expr -> type_expr
val type_list: type_expr -> type_expr
val type_option: type_expr -> type_expr
val path_int: Path.t
val path_char: Path.t
@ -36,6 +37,7 @@ val path_exn: Path.t
val path_array: Path.t
val path_list: Path.t
val path_format: Path.t
val path_option: Path.t
val path_match_failure: Path.t

222
typing/printtyp.ml
View File

@ -79,33 +79,64 @@ let print_name_of_type t =
let check_name_of_type t =
ignore(name_of_type t)
(*
let remove_name_of_type t =
names := List.remove_assq t !names
*)
let visited_objects = ref ([] : type_expr list)
let aliased = ref ([] : type_expr list)
let proxy ty =
let ty = repr ty in
match ty.desc with
Tvariant row -> Btype.row_more row
| _ -> ty
let namable_row row =
row.row_name <> None &&
List.for_all
(fun (_,f) -> match row_field_repr f with
Reither(c,l,_) -> if c then l = [] else List.length l = 1
| _ -> true)
row.row_fields
let rec mark_loops_rec visited ty =
let ty = repr ty in
if List.memq ty visited then begin
if not (List.memq ty !aliased) then
aliased := ty :: !aliased
let px = proxy ty in
if List.memq px visited then begin
if not (List.memq px !aliased) then
aliased := px :: !aliased
end else
let visited = ty :: visited in
match ty.desc with
Tvar -> ()
| Tarrow(ty1, ty2) ->
| Tarrow(_, ty1, ty2) ->
mark_loops_rec visited ty1; mark_loops_rec visited ty2
| Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
| Tconstr(_, tyl, _) ->
List.iter (mark_loops_rec visited) tyl
| Tvariant row ->
let row = row_repr row in
if List.memq px !visited_objects then begin
if not (List.memq px !aliased) then
aliased := px :: !aliased
end else begin
if not (static_row row) then
visited_objects := px :: !visited_objects;
match row.row_name with
Some(p, tyl) when namable_row row ->
List.iter (mark_loops_rec visited) tyl
| _ ->
iter_row (mark_loops_rec visited) row
end
| Tobject (fi, nm) ->
if List.memq ty !visited_objects then begin
if not (List.memq ty !aliased) then
aliased := ty :: !aliased
if List.memq px !visited_objects then begin
if not (List.memq px !aliased) then
aliased := px :: !aliased
end else begin
if opened_object ty then
visited_objects := ty :: !visited_objects;
visited_objects := px :: !visited_objects;
let name =
match !nm with
None -> None
@ -131,6 +162,7 @@ let rec mark_loops_rec visited ty =
| Tfield(_, _, _, ty2) ->
mark_loops_rec visited ty2
| Tnil -> ()
| Tsubst ty -> mark_loops_rec visited ty
| Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
let mark_loops ty = mark_loops_rec [] ty
@ -141,17 +173,31 @@ let reset_loop_marks () =
let reset () =
reset_names (); reset_loop_marks ()
(* disabled in classic mode when printing an unification error *)
let print_labels = ref true
let print_label l =
if !print_labels && l <> "" || is_optional l then begin
print_string l;
print_char ':'
end
let rec print_list pr sep = function
[] -> ()
| [a] -> pr a
| a::l -> pr a; sep (); print_list pr sep l
let rec typexp sch prio0 ty =
let ty = repr ty in
if List.mem_assq ty !names then begin
if (ty.desc = Tvar) && sch && (ty.level <> generic_level)
let px = proxy ty in
if List.mem_assq px !names then begin
if (px.desc = Tvar) && sch && (px.level <> generic_level)
then print_string "'_"
else print_string "'";
print_name_of_type ty
print_name_of_type px
end else begin
let alias = List.memq ty !aliased in
let alias = List.memq px !aliased in
if alias then begin
check_name_of_type ty;
check_name_of_type px;
if prio0 >= 1 then begin open_box 1; print_string "(" end
else open_box 0
end;
@ -162,10 +208,17 @@ let rec typexp sch prio0 ty =
then print_string "'"
else print_string "'_";
print_name_of_type ty
| Tarrow(ty1, ty2) ->
| Tarrow(l, ty1, ty2) ->
if prio >= 2 then begin open_box 1; print_string "(" end
else open_box 0;
typexp sch 2 ty1;
print_label l;
if is_optional l then
match (repr ty1).desc with
Tconstr(path, [ty], _) when path = Predef.path_option ->
typexp sch 2 ty
| _ -> assert false
else
typexp sch 2 ty1;
print_string " ->"; print_space();
typexp sch 1 ty2;
if prio >= 2 then print_string ")";
@ -188,27 +241,103 @@ let rec typexp sch prio0 ty =
end;
path p;
close_box()
| Tvariant row ->
let row = row_repr row in
let fields =
if row.row_closed then
List.filter (fun (_,f) -> row_field_repr f <> Rabsent)
row.row_fields
else row.row_fields
in
let present =
List.filter
(fun (_,f) -> match row_field_repr f with
| Rpresent _ -> true
| _ -> false)
fields in
let all_present = List.length present = List.length fields in
begin match row.row_name with
| Some(p,tyl) when namable_row row ->
open_box 0;
begin match tyl with
[] -> ()
| [ty1] ->
typexp sch 3 ty1; print_space()
| tyl ->
open_box 1; print_string "("; typlist sch 0 "," tyl;
print_string ")"; close_box(); print_space()
end;
if not all_present then
if sch && px.level <> generic_level then print_string "_#"
else print_char '#';
path p;
if not all_present && present <> [] then begin
open_box 1;
print_string "[>";
print_list (fun (s,_) -> print_char '`'; print_string s)
print_space present;
print_char ']';
close_box ()
end;
close_box ()
| _ ->
open_hovbox 0;
if not (row.row_closed && all_present) && sch &&
px.level <> generic_level then print_string "_["
else print_char '[';
if row.row_closed && all_present then () else
if all_present then print_char '>' else print_char '<';
print_list (row_field sch) (fun () -> printf "@,|") fields;
if not (row.row_closed || all_present) then printf "@,| ..";
if present <> [] && not all_present then begin
print_space ();
open_hovbox 2;
print_string "|>";
print_list (fun (s,_) -> print_char '`'; print_string s)
print_space present;
close_box ()
end;
print_char ']';
close_box ()
end
| Tobject (fi, nm) ->
typobject sch ty fi nm
(*
| Tfield _ -> typobject sch ty ty (ref None)
| Tnil -> typobject sch ty ty (ref None)
*)
| Tsubst ty ->
typexp sch prio ty
| _ ->
fatal_error "Printtyp.typexp"
end;
if alias then begin
print_string " as ";
print_string "'";
print_name_of_type ty;
if not (opened_object ty) then
remove_name_of_type ty;
print_name_of_type px;
(* if not (opened_object ty) then
remove_name_of_type px; *)
if prio0 >= 1 then print_string ")";
close_box()
end
end
(*; print_string "["; print_int ty.level; print_string "]"*)
and row_field sch (l,f) =
open_box 2;
print_char '`';
print_string l;
begin match row_field_repr f with
Rpresent None | Reither(true, [], _) -> ()
| Rpresent(Some ty) -> print_space (); typexp sch 0 ty
| Reither(c, tyl,_) ->
print_space ();
if c then printf "&@ ";
typlist sch 0 " &" tyl
| Rabsent -> print_space (); print_string "[]"
end;
close_box ()
and typlist sch prio sep = function
[] -> ()
| [ty] -> typexp sch prio ty
@ -462,7 +591,7 @@ let rec prepare_class_type =
end;
*)
Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
mark_loops ty;
prepare_class_type cty
@ -508,9 +637,17 @@ let rec perform_class_type sch params =
print_break 1 (-2);
print_string "end";
close_box()
| Tcty_fun (ty, cty) ->
| Tcty_fun (l, ty, cty) ->
open_box 0;
typexp sch 2 ty; print_string " ->";
print_label l;
if is_optional l then
match (repr ty).desc with
Tconstr(path, [ty], _) when path = Predef.path_option ->
typexp sch 2 ty
| _ -> assert false
else
typexp sch 2 ty;
print_string " ->";
print_space ();
perform_class_type sch params cty;
close_box ()
@ -715,18 +852,34 @@ let rec filter_trace =
| _ ->
[]
(* Hide variant name, to force printing the expanded type *)
let hide_variant_name t =
match repr t with
{desc = Tvariant row} as t when (row_repr row).row_name <> None ->
newty2 t.level (Tvariant {(row_repr row) with row_name = None})
| _ ->
t
let prepare_expansion (t, t') =
let t' = hide_variant_name t' in
mark_loops t; if t != t' then mark_loops t';
(t, t')
let unification_error unif tr txt1 txt2 =
reset ();
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
let (t3, t4) = mismatch tr in
match tr with
[] | _::[] ->
assert false
| (t1, t1')::(t2, t2')::tr ->
| t1::t2::tr ->
try
let t1, t1' = prepare_expansion t1
and t2, t2' = prepare_expansion t2 in
print_labels := not !Clflags.classic;
open_vbox 0;
let tr = filter_trace tr in
let mark (t, t') = mark_loops t; if t != t' then mark_loops t' in
mark (t1, t1'); mark (t2, t2');
List.iter mark tr;
let tr = List.map prepare_expansion tr in
open_box 0;
txt1 (); print_break 1 2;
type_expansion t1 t1'; print_space();
@ -771,12 +924,17 @@ let unification_error unif tr txt1 txt2 =
| _ ->
()
end;
close_box ()
close_box ();
print_labels := true
with exn ->
print_labels := true;
raise exn
let trace fst txt tr =
(* match tr with
(t1, t1')::(t2, t2')::tr -> *)
trace fst txt (filter_trace tr)
(* | _ ->
()*)
print_labels := not !Clflags.classic;
try
trace fst txt (filter_trace tr);
print_labels := true
with exn ->
print_labels := true;
raise exn

1
typing/printtyp.mli
View File

@ -34,6 +34,7 @@ val class_type: class_type -> unit
val class_declaration: Ident.t -> class_declaration -> unit
val cltype_declaration: Ident.t -> cltype_declaration -> unit
val type_expansion: type_expr -> type_expr -> unit
val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
val trace: bool -> (unit -> unit) -> (type_expr * type_expr) list -> unit
val unification_error:
bool -> (type_expr * type_expr) list ->

70
typing/subst.ml
View File

@ -76,19 +76,22 @@ let type_path s = function
(* Similar to [Ctype.nondep_type_rec]. *)
let rec typexp s ty =
let ty = repr ty in
if (ty.desc = Tvar) || (ty.level < lowest_level) then
ty
else begin
match ty.desc with
Tvar ->
ty
| Tsubst ty ->
ty
| _ ->
let desc = ty.desc in
save_desc ty desc;
let ty' = newmarkedgenvar () in (* Stub *)
ty.desc <- Tlink ty';
let ty' = newgenvar () in (* Stub *)
ty.desc <- Tsubst ty';
ty'.desc <-
begin match desc with
Tvar | Tlink _ ->
fatal_error "Subst.typexp"
| Tarrow(t1, t2) ->
Tarrow(typexp s t1, typexp s t2)
| Tarrow(l, t1, t2) ->
Tarrow(l, typexp s t1, typexp s t2)
| Ttuple tl ->
Ttuple(List.map (typexp s) tl)
| Tconstr(p, tl, abbrev) ->
@ -99,6 +102,41 @@ let rec typexp s ty =
None -> None
| Some (p, tl) ->
Some (type_path s p, List.map (typexp s) tl)))
| Tvariant row ->
let row = row_repr row in
let more = repr row.row_more in
(* We must substitute in a subtle way *)
begin match more.desc with
Tsubst ty2 ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
| _ ->
(* We create a new copy *)
let bound = ref [] in
let fields =
List.map
(fun (l,fi) -> l,
match row_field_repr fi with
Rpresent (Some ty) -> Rpresent(Some (typexp s ty))
| Reither(c, l, _) ->
let l = List.map (typexp s) l in
bound := l @ !bound;
Reither(c, l, ref None)
| fi -> fi)
row.row_fields
and name =
may_map (fun (p,l) -> p, List.map (typexp s) l) row.row_name in
let var =
Tvariant { row_fields = fields; row_more = newgenvar();
row_bound = !bound;
row_closed = row.row_closed; row_name = name }
in
(* Remember it for other occurences *)
save_desc more more.desc;
more.desc <- ty.desc;
var
end
| Tfield(label, kind, t1, t2) ->
begin match field_kind_repr kind with
Fpresent ->
@ -110,9 +148,10 @@ let rec typexp s ty =
end
| Tnil ->
Tnil
| Tsubst _ ->
assert false
end;
ty'
end
(*
Always make a copy of the type. If this is not done, type levels
@ -121,7 +160,6 @@ let rec typexp s ty =
let type_expr s ty =
let ty' = typexp s ty in
cleanup_types ();
unmark_type ty';
ty'
let type_declaration s decl =
@ -148,7 +186,6 @@ let type_declaration s decl =
}
in
cleanup_types ();
unmark_type_decl decl;
decl
let class_signature s sign =
@ -162,8 +199,8 @@ let rec class_type s =
Tcty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty)
| Tcty_signature sign ->
Tcty_signature (class_signature s sign)
| Tcty_fun (ty, cty) ->
Tcty_fun (typexp s ty, class_type s cty)
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, typexp s ty, class_type s cty)
let class_declaration s decl =
let decl =
@ -177,12 +214,6 @@ let class_declaration s decl =
end }
in
cleanup_types ();
List.iter unmark_type decl.cty_params;
unmark_class_type decl.cty_type;
begin match decl.cty_new with
None -> ()
| Some ty -> unmark_type ty
end;
decl
let cltype_declaration s decl =
@ -192,14 +223,11 @@ let cltype_declaration s decl =
clty_path = type_path s decl.clty_path }
in
cleanup_types ();
List.iter unmark_type decl.clty_params;
unmark_class_type decl.clty_type;
decl
let class_type s cty =
let cty = class_type s cty in
cleanup_types ();
unmark_class_type cty;
cty
let value_description s descr =

209
typing/typeclass.ml
View File

@ -25,6 +25,7 @@ type error =
| Method_type_mismatch of string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
| Pattern_type_clash of type_expr
| Repeated_parameter
| Unbound_class of Longident.t
@ -84,7 +85,7 @@ let rec generalize_class_type =
| Tcty_signature {cty_self = sty; cty_vars = vars } ->
Ctype.generalize sty;
Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
Ctype.generalize ty;
generalize_class_type cty
@ -106,8 +107,8 @@ let rec constructor_type constr cty =
constructor_type constr cty
| Tcty_signature sign ->
constr
| Tcty_fun (ty, cty) ->
Ctype.newty (Tarrow (ty, constructor_type constr cty))
| Tcty_fun (l, ty, cty) ->
Ctype.newty (Tarrow (l, ty, constructor_type constr cty))
let rec class_body cty =
match cty with
@ -115,7 +116,7 @@ let rec class_body cty =
cty (* Only class bodies can be abbreviated *)
| Tcty_signature sign ->
cty
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
class_body cty
let rec extract_constraints cty =
@ -135,8 +136,8 @@ let rec abbreviate_class_type path params cty =
match cty with
Tcty_constr (_, _, _) | Tcty_signature _ ->
Tcty_constr (path, params, cty)
| Tcty_fun (ty, cty) ->
Tcty_fun (ty, abbreviate_class_type path params cty)
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, ty, abbreviate_class_type path params cty)
let rec closed_class_type =
function
@ -148,7 +149,7 @@ let rec closed_class_type =
Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
sign.cty_vars
true
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
Ctype.closed_schema ty
&&
closed_class_type cty
@ -167,7 +168,7 @@ let rec limited_generalize rv =
Ctype.limited_generalize rv sign.cty_self;
Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
sign.cty_vars
| Tcty_fun (ty, cty) ->
| Tcty_fun (_, ty, cty) ->
Ctype.limited_generalize rv ty;
limited_generalize rv cty
@ -239,10 +240,11 @@ let type_constraint val_env sty sty' loc =
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
let make_method cl_num expr =
{ pexp_desc =
Pexp_function [mkpat (Ppat_alias (mkpat(Ppat_var "self-*"),
"self-" ^ cl_num)),
expr];
pexp_loc = Location.none }
Pexp_function ("", None,
[mkpat (Ppat_alias (mkpat(Ppat_var "self-*"),
"self-" ^ cl_num)),
expr]);
pexp_loc = expr.pexp_loc }
(*******************************)
@ -339,10 +341,10 @@ and class_type env scty =
| Pcty_signature (sty, sign) ->
Tcty_signature (class_signature env sty sign)
| Pcty_fun (sty, scty) ->
| Pcty_fun (l, sty, scty) ->
let ty = transl_simple_type env false sty in
let cty = class_type env scty in
Tcty_fun (ty, cty)
Tcty_fun (l, ty, cty)
(*******************************)
@ -389,7 +391,7 @@ let rec class_field cl_num self_type meths vars
(val_env, met_env, par_env)
in
(val_env, met_env, par_env,
Cf_inher (parent, inh_vars, inh_meths)::fields,
lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
concr_meths, inh_vals)
| Pcf_val (lab, mut, sexp, loc) ->
@ -402,7 +404,7 @@ let rec class_field cl_num self_type meths vars
let (id, val_env, met_env, par_env) =
enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
in
(val_env, met_env, par_env, Cf_val (lab, id, exp) :: fields,
(val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
concr_meths, inh_vals)
| Pcf_virt (lab, priv, sty, loc) ->
@ -410,18 +412,28 @@ let rec class_field cl_num self_type meths vars
(val_env, met_env, par_env, fields, concr_meths, inh_vals)
| Pcf_meth (lab, priv, expr, loc) ->
let expr = make_method cl_num expr in
let meth_expr = make_method cl_num expr in
Ctype.raise_nongen_level ();
let (_, ty) =
Ctype.filter_self_method val_env lab priv meths self_type
in
let meth_type = Ctype.newvar () in
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type in
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type "" in
Ctype.unify val_env obj_ty self_type;
Ctype.unify val_env res_ty ty;
let texp = type_expect met_env expr meth_type in
let ty' = type_approx met_env expr in
begin try Ctype.unify met_env ty' res_ty with Ctype.Unify trace ->
raise(Typecore.Error(expr.pexp_loc, Expr_type_clash(trace)))
end;
Ctype.end_def ();
(val_env, met_env, par_env, Cf_meth (lab, texp)::fields,
let field =
lazy begin
Ctype.raise_nongen_level ();
let texp = type_expect met_env meth_expr meth_type in
Ctype.end_def ();
Cf_meth (lab, texp)
end in
(val_env, met_env, par_env, field::fields,
Concr.add lab concr_meths, inh_vals)
| Pcf_cstr (sty, sty', loc) ->
@ -455,19 +467,23 @@ let rec class_field cl_num self_type meths vars
(let_bound_idents defs)
([], met_env, par_env)
in
(val_env, met_env, par_env, Cf_let (rec_flag, defs, vals)::fields,
(val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
concr_meths, inh_vals)
| Pcf_init expr ->
let expr = make_method cl_num expr in
Ctype.raise_nongen_level ();
let meth_type = Ctype.newvar () in
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type in
Ctype.unify val_env obj_ty self_type;
Ctype.unify val_env res_ty (Ctype.instance Predef.type_unit);
let texp = type_expect met_env expr meth_type in
Ctype.end_def ();
(val_env, met_env, par_env, Cf_init texp::fields, concr_meths, inh_vals)
let field =
lazy begin
Ctype.raise_nongen_level ();
let meth_type = Ctype.newvar () in
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type "" in
Ctype.unify val_env obj_ty self_type;
Ctype.unify val_env res_ty (Ctype.instance Predef.type_unit);
let texp = type_expect met_env expr meth_type in
Ctype.end_def ();
Cf_init texp
end in
(val_env, met_env, par_env, field::fields, concr_meths, inh_vals)
and class_structure cl_num val_env met_env (spat, str) =
(* Environment for substructures *)
@ -496,8 +512,9 @@ and class_structure cl_num val_env met_env (spat, str) =
(val_env, meth_env, par_env, [], Concr.empty, StringSet.empty)
str
in
let fields = List.map Lazy.force (List.rev fields) in
{cl_field = List.rev fields;
{cl_field = fields;
cl_meths = Meths.map (function (id, ty) -> id) !meths},
{cty_self = self_type;
@ -542,9 +559,32 @@ and class_expr cl_num val_env met_env scl =
{cl_desc = Tclass_structure desc;
cl_loc = scl.pcl_loc;
cl_type = Tcty_signature ty}
| Pcl_fun (spat, scl') ->
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let scases =
[{ppat_loc = loc; ppat_desc =
Ppat_construct(Longident.Lident"Some",
Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
false)},
{pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
{ppat_loc = loc; ppat_desc =
Ppat_construct(Longident.Lident"None", None, false)},
default] in
let smatch =
{pexp_loc = loc; pexp_desc =
Pexp_match({pexp_loc = loc; pexp_desc =
Pexp_ident(Longident.Lident"*opt*")},
scases)} in
let sfun =
{pcl_loc = scl.pcl_loc; pcl_desc =
Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
{pcl_loc = scl.pcl_loc; pcl_desc =
Pcl_let(Nonrecursive, [spat, smatch], sbody)})}
in
class_expr cl_num val_env met_env sfun
| Pcl_fun (l, _, spat, scl') ->
let (pat, pv, val_env, met_env) =
Typecore.type_class_arg_pattern cl_num val_env met_env spat
Typecore.type_class_arg_pattern cl_num val_env met_env l spat
in
let pv =
List.map
@ -555,35 +595,91 @@ and class_expr cl_num val_env met_env scl =
pexp_loc = Location.none}))
pv
in
Parmatch.check_partial pat.pat_loc
[pat, (* Dummy expression *)
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none;
exp_type = Ctype.none;
exp_env = Env.empty }];
let rec all_labeled = function
Tcty_fun ("", _, _) -> false
| Tcty_fun (l, _, ty_fun) -> l.[0] <> '?' && all_labeled ty_fun
| _ -> true
in
let partial =
Parmatch.check_partial val_env pat.pat_loc
[pat, (* Dummy expression *)
{exp_desc = Texp_constant (Asttypes.Const_int 1);
exp_loc = Location.none;
exp_type = Ctype.none;
exp_env = Env.empty }] in
Ctype.raise_nongen_level ();
let cl = class_expr cl_num val_env met_env scl' in
Ctype.end_def ();
{cl_desc = Tclass_fun (pat, pv, cl);
if Btype.is_optional l && all_labeled cl.cl_type then
Location.print_warning pat.pat_loc
(Warnings.Other "This optional argument cannot be erased");
{cl_desc = Tclass_fun (pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Tcty_fun (pat.pat_type, cl.cl_type)}
cl_type = Tcty_fun (l, pat.pat_type, cl.cl_type)}
| Pcl_apply (scl', sargs) ->
let cl = class_expr cl_num val_env met_env scl' in
let rec type_args ty_fun =
function
[] ->
([], ty_fun)
| sarg1 :: sargl ->
begin match ty_fun with
Tcty_fun (ty, cty) ->
let arg1 = type_expect val_env sarg1 ty in
let (argl, ty_res) = type_args cty sargl in
(arg1 :: argl, ty_res)
| _ ->
raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
end
let rec type_args args omitted ty_fun sargs more_sargs =
match ty_fun with
| Tcty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] ->
let name = Btype.label_name l in
let sargs, more_sargs, arg =
if !Clflags.classic && not (Btype.is_optional l) then begin
match sargs, more_sargs with
(l', sarg0)::_, _ ->
raise(Error(sarg0.pexp_loc, Apply_wrong_label(l')))
| _, (l', sarg0)::more_sargs ->
if l <> l' && l' <> "" then
raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
else ([], more_sargs, Some(type_argument val_env sarg0 ty))
| _ ->
assert false
end else try
let (l', sarg0, sargs, more_sargs) =
try
let (l', sarg0, sargs1, sargs2) =
Btype.extract_label name sargs
in (l', sarg0, sargs1 @ sargs2, more_sargs)
with Not_found ->
let (l', sarg0, sargs1, sargs2) =
Btype.extract_label name more_sargs
in (l', sarg0, sargs @ sargs1, sargs2)
in
sargs, more_sargs,
if Btype.is_optional l' || not (Btype.is_optional l) then
Some (type_argument val_env sarg0 ty)
else
let arg = type_argument val_env
sarg0 (extract_option_type val_env ty) in
Some (option_some arg)
with Not_found ->
sargs, more_sargs,
if Btype.is_optional l &&
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
then
Some (option_none ty Location.none)
else None
in
let omitted = if arg = None then (l,ty) :: omitted else omitted in
type_args (arg::args) omitted ty_fun sargs more_sargs
| _ ->
match sargs @ more_sargs with
(l, sarg0)::_ ->
if omitted <> [] then
raise(Error(sarg0.pexp_loc, Apply_wrong_label l))
else
raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
| [] ->
(List.rev args,
List.fold_left
(fun ty_fun (l,ty) -> Tcty_fun(l,ty,ty_fun))
ty_fun omitted)
in
let (args, cty) =
if !Clflags.classic then
type_args [] [] cl.cl_type [] sargs
else
type_args [] [] cl.cl_type sargs []
in
let (args, cty) = type_args cl.cl_type sargs in
{cl_desc = Tclass_apply (cl, args);
cl_loc = scl.pcl_loc;
cl_type = cty}
@ -985,6 +1081,11 @@ let report_error = function
| Cannot_apply clty ->
print_string
"This class expression is not a class function, it cannot be applied"
| Apply_wrong_label l ->
if l = "" then
print_string "This argument cannot be applied without label"
else
printf "This argument cannot be applied with label %s:" l
| Pattern_type_clash ty ->
(* XXX Trace *)
(* XXX Revoir message d'erreur *)

1
typing/typeclass.mli
View File

@ -43,6 +43,7 @@ type error =
| Method_type_mismatch of string * (type_expr * type_expr) list
| Structure_expected of class_type
| Cannot_apply of class_type
| Apply_wrong_label of label
| Pattern_type_clash of type_expr
| Repeated_parameter
| Unbound_class of Longident.t

461
typing/typecore.ml
View File

@ -34,6 +34,7 @@ type error =
| Orpat_not_closed
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
| Label_multiply_defined of Longident.t
| Label_missing
| Label_not_mutable of Longident.t
@ -49,6 +50,7 @@ type error =
| Value_multiply_overridden of string
| Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
| Too_many_arguments
| Abstract_wrong_label of label * type_expr
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t
@ -68,6 +70,26 @@ let type_constant = function
| Const_string _ -> instance Predef.type_string
| Const_float _ -> instance Predef.type_float
(* Specific version of type_option, using newty rather than newgenty *)
let type_option ty =
newty (Tconstr(Predef.path_option,[ty], ref Mnil))
let option_none ty loc =
let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
{ exp_desc = Texp_construct(cnone, []);
exp_type = ty; exp_loc = loc; exp_env = Env.initial }
let option_some texp =
let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in
{ exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc;
exp_type = type_option texp.exp_type; exp_env = texp.exp_env }
let extract_option_type env ty =
match expand_head env ty with {desc = Tconstr(path, [ty], _)}
when Path.same path Predef.path_option -> ty
| _ -> assert false
(* Typing of patterns *)
let unify_pat env pat expected_ty =
@ -85,6 +107,17 @@ let enter_variable loc name ty =
pattern_variables := (id, ty) :: !pattern_variables;
id
let rec extract_row_fields p =
match p.pat_desc with
Tpat_or(p1, p2) ->
extract_row_fields p1 @ extract_row_fields p2
| Tpat_variant(l, None, _) ->
[l, Rpresent None]
| Tpat_variant(l, Some{pat_desc = Tpat_any; pat_type = ty}, _) ->
[l, Rpresent(Some ty)]
| _ ->
raise Not_found
let rec type_pat env sp =
match sp.ppat_desc with
Ppat_any ->
@ -101,7 +134,15 @@ let rec type_pat env sp =
pat_env = env }
| Ppat_alias(sp, name) ->
let p = type_pat env sp in
let id = enter_variable sp.ppat_loc name p.pat_type in
let ty_var =
try
let fields = extract_row_fields p in
newty (Tvariant { row_fields = fields; row_more = newvar();
row_closed = false; row_name = None;
row_bound = [] })
with Not_found -> p.pat_type
in
let id = enter_variable sp.ppat_loc name ty_var in
{ pat_desc = Tpat_alias(p, id);
pat_loc = sp.ppat_loc;
pat_type = p.pat_type;
@ -141,6 +182,18 @@ let rec type_pat env sp =
pat_loc = sp.ppat_loc;
pat_type = ty_res;
pat_env = env }
| Ppat_variant(l, sarg) ->
let arg = may_map (type_pat env) sarg in
let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
let row = { row_fields = [l, Reither(arg = None, arg_type,ref None)];
row_bound = arg_type;
row_closed = false;
row_more = newvar ();
row_name = None } in
{ pat_desc = Tpat_variant(l, arg, row);
pat_loc = sp.ppat_loc;
pat_type = newty (Tvariant row);
pat_env = env }
| Ppat_record lid_sp_list ->
let rec check_duplicates = function
[] -> ()
@ -215,9 +268,10 @@ let type_pattern_list env spatl =
let new_env = add_pattern_variables env in
(patl, new_env)
let type_class_arg_pattern cl_num val_env met_env spat =
let type_class_arg_pattern cl_num val_env met_env l spat =
pattern_variables := [];
let pat = type_pat val_env spat in
if is_optional l then unify_pat val_env pat (type_option (newvar ()));
let (pv, met_env) =
List.fold_right
(fun (id, ty) (pv, env) ->
@ -266,6 +320,8 @@ let rec iter_pattern f p =
List.iter (iter_pattern f) pl
| Tpat_construct (_, pl) ->
List.iter (iter_pattern f) pl
| Tpat_variant (_, p, _) ->
may (iter_pattern f) p
| Tpat_record fl ->
List.iter (fun (_, p) -> iter_pattern f p) fl
| Tpat_or (p, p') ->
@ -283,11 +339,16 @@ let rec is_nonexpansive exp =
| Texp_let(rec_flag, pat_exp_list, body) ->
List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &
is_nonexpansive body
| Texp_apply(e, None::el) ->
is_nonexpansive e &&
List.for_all (function None -> true | Some exp -> is_nonexpansive e) el
| Texp_function _ -> true
| Texp_tuple el ->
List.for_all is_nonexpansive el
| Texp_construct(_, el) ->
List.for_all is_nonexpansive el
| Texp_variant(_, Some e) -> is_nonexpansive e
| Texp_variant(_, None) -> true
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
(fun (lbl, exp) -> lbl.lbl_mut = Immutable & is_nonexpansive exp)
@ -320,22 +381,24 @@ let type_format loc fmt =
'%' ->
scan_format (j+1)
| 's' ->
newty (Tarrow(instance Predef.type_string, scan_format (j+1)))
newty (Tarrow("",instance Predef.type_string, scan_format (j+1)))
| 'c' ->
newty (Tarrow(instance Predef.type_char, scan_format (j+1)))
newty (Tarrow("",instance Predef.type_char, scan_format (j+1)))
| 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
newty (Tarrow(instance Predef.type_int, scan_format (j+1)))
newty (Tarrow("",instance Predef.type_int, scan_format (j+1)))
| 'f' | 'e' | 'E' | 'g' | 'G' ->
newty (Tarrow(instance Predef.type_float, scan_format (j+1)))
newty (Tarrow("",instance Predef.type_float, scan_format (j+1)))
| 'b' ->
newty (Tarrow(instance Predef.type_bool, scan_format (j+1)))
newty (Tarrow("",instance Predef.type_bool, scan_format (j+1)))
| 'a' ->
let ty_arg = newvar() in
newty (Tarrow (newty (Tarrow(ty_input,
newty (Tarrow (ty_arg, ty_result)))),
newty (Tarrow (ty_arg, scan_format (j+1)))))
newty (Tarrow ("",
newty (Tarrow("", ty_input,
newty (Tarrow ("", ty_arg,
ty_result)))),
newty (Tarrow ("", ty_arg, scan_format (j+1)))))
| 't' ->
newty (Tarrow(newty (Tarrow(ty_input, ty_result)),
newty (Tarrow("", newty (Tarrow("", ty_input, ty_result)),
scan_format (j+1)))
| c ->
raise(Error(loc, Bad_format(String.sub fmt i (j-i+1))))
@ -344,6 +407,37 @@ let type_format loc fmt =
newty
(Tconstr(Predef.path_format, [scan_format 0; ty_input; ty_result], ref Mnil))
(* Approximate the type of an expression, for better recursion *)
let rec approx_type sty =
match sty.ptyp_desc with
Ptyp_arrow (p, _, sty) ->
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
newty (Tarrow (p, ty1, approx_type sty))
| _ -> newvar ()
let rec type_approx env sexp =
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
| Pexp_function (p,_,(_,e)::_) when is_optional p ->
newty (Tarrow(p, type_option (newvar ()), type_approx env e))
| Pexp_function (p,_,(_,e)::_) ->
newty (Tarrow(p, newvar (), type_approx env e))
| Pexp_match (_, (_,e)::_) -> type_approx env e
| Pexp_try (e, _) -> type_approx env e
| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
| Pexp_ifthenelse (_,e,_) -> type_approx env e
| Pexp_sequence (_,e) -> type_approx env e
| Pexp_constraint (e, Some sty, _) ->
let ty = type_approx env e
and ty' = Typetexp.transl_simple_type env false sty in
(try unify env ty ty'; ty' with Unify trace ->
raise(Error(sexp.pexp_loc, Expr_type_clash trace)))
| Pexp_constraint (_, _, Some sty) ->
Typetexp.transl_simple_type env false sty
| Pexp_constraint (e, _, _) -> type_approx env e
| _ -> newvar ()
(* Typing of expressions *)
let unify_exp env exp expected_ty =
@ -392,31 +486,22 @@ let rec type_exp env sexp =
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
exp_env = env }
| Pexp_function caselist ->
let ty_arg = newvar() and ty_res = newvar() in
| Pexp_function (_, Some _, _) -> (* defined in type_expect *)
type_expect env sexp (newvar())
| Pexp_function (l, None, caselist) ->
let ty_arg =
if is_optional l then type_option(newvar()) else newvar()
and ty_res = newvar() in
let cases = type_cases env ty_arg ty_res caselist in
Parmatch.check_unused cases;
Parmatch.check_partial sexp.pexp_loc cases;
{ exp_desc = Texp_function cases;
Parmatch.check_unused env cases;
let partial = Parmatch.check_partial env sexp.pexp_loc cases in
{ exp_desc = Texp_function(cases, partial);
exp_loc = sexp.pexp_loc;
exp_type = newty (Tarrow(ty_arg, ty_res));
exp_type = newty (Tarrow(l, ty_arg, ty_res));
exp_env = env }
| Pexp_apply(sfunct, sargs) ->
let funct = type_exp env sfunct in
let rec type_args ty_fun = function
[] ->
([], ty_fun)
| sarg1 :: sargl ->
let (ty1, ty2) =
try
filter_arrow env ty_fun
with Unify _ ->
raise(Error(sfunct.pexp_loc,
Apply_non_function funct.exp_type)) in
let arg1 = type_expect env sarg1 ty1 in
let (argl, ty_res) = type_args ty2 sargl in
(arg1 :: argl, ty_res) in
let (args, ty_res) = type_args funct.exp_type sargs in
let (args, ty_res) = type_application env funct sargs in
{ exp_desc = Texp_apply(funct, args);
exp_loc = sexp.pexp_loc;
exp_type = ty_res;
@ -425,9 +510,9 @@ let rec type_exp env sexp =
let arg = type_exp env sarg in
let ty_res = newvar() in
let cases = type_cases env arg.exp_type ty_res caselist in
Parmatch.check_unused cases;
Parmatch.check_partial sexp.pexp_loc cases;
{ exp_desc = Texp_match(arg, cases);
Parmatch.check_unused env cases;
let partial = Parmatch.check_partial env sexp.pexp_loc cases in
{ exp_desc = Texp_match(arg, cases, partial);
exp_loc = sexp.pexp_loc;
exp_type = ty_res;
exp_env = env }
@ -435,7 +520,7 @@ let rec type_exp env sexp =
let body = type_exp env sbody in
let cases =
type_cases env (instance Predef.type_exn) body.exp_type caselist in
Parmatch.check_unused cases;
Parmatch.check_unused env cases;
{ exp_desc = Texp_try(body, cases);
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
@ -447,25 +532,17 @@ let rec type_exp env sexp =
exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
exp_env = env }
| Pexp_construct(lid, sarg, explicit_arity) ->
let constr =
try
Env.lookup_constructor lid env
with Not_found ->
raise(Error(sexp.pexp_loc, Unbound_constructor lid)) in
let sargs =
match sarg with
None -> []
| Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
| Some se -> [se] in
if List.length sargs <> constr.cstr_arity then
raise(Error(sexp.pexp_loc, Constructor_arity_mismatch(lid,
constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) = instance_constructor constr in
let args = List.map2 (type_expect env) sargs ty_args in
{ exp_desc = Texp_construct(constr, args);
type_construct env sexp.pexp_loc lid sarg explicit_arity (newvar ())
| Pexp_variant(l, sarg) ->
let arg = may_map (type_exp env) sarg in
let arg_type = may_map (fun arg -> arg.exp_type) arg in
{ exp_desc = Texp_variant(l, arg);
exp_loc = sexp.pexp_loc;
exp_type = ty_res;
exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
row_more = newvar ();
row_bound = [];
row_closed = false;
row_name = None});
exp_env = env }
| Pexp_record(lid_sexp_list, opt_sexp) ->
let ty = newvar() in
@ -653,7 +730,7 @@ let rec type_exp env sexp =
filter_self_method env met Private meths obj.exp_type
in
let method_type = newvar () in
let (obj_ty, res_ty) = filter_arrow env method_type in
let (obj_ty, res_ty) = filter_arrow env method_type "" in
unify env obj_ty desc.val_type;
unify env res_ty typ;
(Texp_apply({exp_desc = Texp_ident(Path.Pident method_id,
@ -662,10 +739,10 @@ let rec type_exp env sexp =
exp_loc = sexp.pexp_loc;
exp_type = method_type;
exp_env = env },
[{exp_desc = Texp_ident(path, desc);
exp_loc = obj.exp_loc;
exp_type = desc.val_type;
exp_env = env }]),
[Some {exp_desc = Texp_ident(path, desc);
exp_loc = obj.exp_loc;
exp_type = desc.val_type;
exp_env = env }]),
typ)
| _ ->
assert false
@ -774,6 +851,165 @@ let rec type_exp env sexp =
exp_type = ty;
exp_env = env }
and type_argument env sarg ty_expected =
match expand_head env ty_expected, sarg with
| _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
type_expect env sarg ty_expected
| {desc = Tarrow("",ty_arg,ty_res)}, _ ->
(* apply optional arguments when expected type is "" *)
let texp = type_exp env sarg in
let rec make_args args ty_fun =
match (expand_head env ty_fun).desc with
| Tarrow (l,ty_arg,ty_fun) when is_optional l ->
make_args (Some(option_none ty_arg sarg.pexp_loc) :: args) ty_fun
| Tarrow (l,_,_) when l = "" || !Clflags.classic ->
args, ty_fun
| Tvar -> args, ty_fun
| _ -> [], texp.exp_type
in
let args, ty_fun = make_args [] texp.exp_type in
unify_exp env {texp with exp_type = ty_fun} ty_expected;
if args = [] then texp else
(* eta-expand to avoid side effects *)
let var_pair name ty =
let id = Ident.create name in
{pat_desc = Tpat_var id; pat_type = ty_arg;
pat_loc = Location.none; pat_env = env},
{exp_type = ty_arg; exp_loc = Location.none; exp_env = env; exp_desc =
Texp_ident(Path.Pident id,{val_type = ty_arg; val_kind = Val_reg})}
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
let func texp =
{ texp with exp_type = ty_fun; exp_desc =
Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
Texp_apply (texp, args@[Some eta_var])}],
Total) } in
if is_nonexpansive texp then func texp else
(* let-expand to have side effects *)
let let_pat, let_var = var_pair "let" texp.exp_type in
{ texp with exp_type = ty_fun; exp_desc =
Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
| _ ->
type_expect env sarg ty_expected
and type_application env funct sargs =
let result_type omitted ty_fun =
List.fold_left
(fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun)))
ty_fun omitted
in
let rec type_unknown_args args omitted ty_fun = function
[] ->
(List.rev args, result_type omitted ty_fun)
| (l1, sarg1) :: sargl ->
let (ty1, ty2) =
try
filter_arrow env ty_fun l1
with Unify _ ->
let ty_res = result_type omitted (expand_head env ty_fun) in
match ty_res with
{desc=Tarrow _} ->
raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
| _ ->
raise(Error(funct.exp_loc,
Apply_non_function funct.exp_type)) in
let arg1 = type_expect env sarg1 ty1 in
type_unknown_args (Some arg1 :: args) omitted ty2 sargl
in
let rec type_args args omitted ty_fun ty_old sargs more_sargs =
match expand_head env ty_fun with
{desc=Tarrow (l, ty, ty_fun); level=lv} as ty_fun'
when sargs <> [] || more_sargs <> [] ->
let name = label_name l in
let sargs, more_sargs, arg =
if !Clflags.classic && not (is_optional l) then begin
(* In classic mode, omitted = [] *)
match sargs, more_sargs with
(l', sarg0) :: _, _ ->
raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
| _, (l', sarg0) :: more_sargs ->
if l <> l' && l' <> "" then
raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
else ([], more_sargs, Some (type_argument env sarg0 ty))
| _ ->
assert false
end else try
let (l', sarg0, sargs, more_sargs) =
try
let (l', sarg0, sargs1, sargs2) = extract_label name sargs
in (l', sarg0, sargs1 @ sargs2, more_sargs)
with Not_found ->
let (l', sarg0, sargs1, sargs2) = extract_label name more_sargs
in (l', sarg0, sargs @ sargs1, sargs2)
in
sargs, more_sargs,
if is_optional l' || not (is_optional l) then
Some (type_argument env sarg0 ty)
else
let arg = type_argument env sarg0 (extract_option_type env ty) in
Some (option_some arg)
with Not_found ->
sargs, more_sargs,
if is_optional l &&
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
then
Some (option_none ty Location.none)
else None
in
let omitted = if arg = None then (l,ty,lv) :: omitted else omitted in
let ty_old = if sargs = [] then ty_fun else ty_old in
type_args (arg::args) omitted ty_fun ty_old sargs more_sargs
| _ ->
match sargs with
(l, sarg0) :: _ when !Clflags.classic ->
raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)));
| _ ->
type_unknown_args args omitted ty_fun (sargs @ more_sargs)
in
match funct.exp_desc, sargs with
(* Special case for ignore: avoid discarding warning *)
Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
["", sarg] ->
let ty_arg, ty_res = filter_arrow env funct.exp_type "" in
let exp = type_expect env sarg ty_arg in
begin match expand_head env exp.exp_type with
| {desc=Tarrow(_, _, _)} ->
Location.print_warning exp.exp_loc Warnings.Partial_application
| _ -> ()
end;
([Some exp], ty_res)
| _ ->
let ty = funct.exp_type in
if !Clflags.classic then
type_args [] [] ty ty [] sargs
else
type_args [] [] ty ty sargs []
and type_construct env loc lid sarg explicit_arity ty_expected =
let constr =
try
Env.lookup_constructor lid env
with Not_found ->
raise(Error(loc, Unbound_constructor lid)) in
let sargs =
match sarg with
None -> []
| Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
| Some se -> [se] in
if List.length sargs <> constr.cstr_arity then
raise(Error(loc, Constructor_arity_mismatch
(lid, constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) = instance_constructor constr in
let texp =
{ exp_desc = Texp_construct(constr, []);
exp_loc = loc;
exp_type = ty_res;
exp_env = env } in
unify_exp env texp ty_expected;
let args = List.map2 (type_expect env) sargs ty_args in
{ 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. *)
@ -793,6 +1029,8 @@ and type_expect env sexp ty_expected =
exp_env = env } in
unify_exp env exp ty_expected;
exp
| Pexp_construct(lid, sarg, explicit_arity) ->
type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
let body = type_expect new_env sbody ty_expected in
@ -807,11 +1045,43 @@ and type_expect env sexp ty_expected =
exp_loc = sexp.pexp_loc;
exp_type = exp2.exp_type;
exp_env = env }
| Pexp_function caselist ->
let (ty_arg, ty_res) =
try filter_arrow env ty_expected with Unify _ ->
raise(Error(sexp.pexp_loc, Too_many_arguments))
| Pexp_function (l, Some default, [spat, sbody]) ->
let loc = default.pexp_loc in
let scases =
[{ppat_loc = loc; ppat_desc =
Ppat_construct(Longident.Lident"Some",
Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
false)},
{pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
{ppat_loc = loc; ppat_desc =
Ppat_construct(Longident.Lident"None", None, false)},
default] in
let smatch =
{pexp_loc = loc; pexp_desc =
Pexp_match({pexp_loc = loc; pexp_desc =
Pexp_ident(Longident.Lident"*opt*")},
scases)} in
let sfun =
{pexp_loc = sexp.pexp_loc; pexp_desc =
Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
{pexp_loc = sexp.pexp_loc; pexp_desc =
Pexp_let(Nonrecursive,[spat,smatch],sbody)}])}
in
type_expect env sfun ty_expected
| Pexp_function (l, _, caselist) ->
let (ty_arg, ty_res) =
try filter_arrow env ty_expected l
with Unify _ ->
match expand_head env ty_expected with
{desc = Tarrow _} as ty ->
raise(Error(sexp.pexp_loc, Abstract_wrong_label(l, ty)))
| _ ->
raise(Error(sexp.pexp_loc, Too_many_arguments))
in
if is_optional l then begin
try unify env ty_arg (type_option(newvar()))
with Unify _ -> assert false
end;
let cases =
List.map
(fun (spat, sexp) ->
@ -821,11 +1091,20 @@ and type_expect env sexp ty_expected =
(pat, exp))
caselist
in
Parmatch.check_unused cases;
Parmatch.check_partial sexp.pexp_loc cases;
{ exp_desc = Texp_function cases;
let rec all_labeled ty =
match (repr ty).desc with
Tarrow ("", _, _) | Tvar -> false
| Tarrow (l, _, ty) -> l.[0] <> '?' && all_labeled ty
| _ -> true
in
if is_optional l && all_labeled ty_res then
Location.print_warning (fst (List.hd cases)).pat_loc
(Warnings.Other "This optional argument cannot be erased");
Parmatch.check_unused env cases;
let partial = Parmatch.check_partial env sexp.pexp_loc cases in
{ exp_desc = Texp_function(cases, partial);
exp_loc = sexp.pexp_loc;
exp_type = newty (Tarrow(ty_arg, ty_res));
exp_type = newty (Tarrow(l, ty_arg, ty_res));
exp_env = env }
| _ ->
let exp = type_exp env sexp in
@ -837,7 +1116,7 @@ and type_expect env sexp ty_expected =
and type_statement env sexp =
let exp = type_exp env sexp in
match (expand_head env exp.exp_type).desc with
| Tarrow(_, _) ->
| Tarrow(_, _, _) ->
Location.print_warning sexp.pexp_loc Warnings.Partial_application;
exp
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
@ -864,6 +1143,10 @@ and type_let env rec_flag spat_sexp_list =
let (pat_list, new_env) =
type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
in
if rec_flag = Recursive then
List.iter2
(fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
pat_list spat_sexp_list;
let exp_env =
match rec_flag with Nonrecursive -> env | Recursive -> new_env in
let exp_list =
@ -871,7 +1154,7 @@ and type_let env rec_flag spat_sexp_list =
(fun (spat, sexp) pat -> type_expect exp_env sexp pat.pat_type)
spat_sexp_list pat_list in
List.iter2
(fun pat exp -> Parmatch.check_partial pat.pat_loc [pat, exp])
(fun pat exp -> ignore(Parmatch.check_partial env pat.pat_loc [pat, exp]))
pat_list exp_list;
end_def();
List.iter2
@ -946,12 +1229,26 @@ let report_error = function
print_string "but is here used with type")
| Apply_non_function typ ->
begin match (repr typ).desc with
Tarrow(_, _) ->
Tarrow _ ->
print_string "This function is applied to too many arguments"
| _ ->
print_string
"This expression is not a function, it cannot be applied"
end
| Apply_wrong_label (l, ty) ->
reset (); mark_loops ty;
open_vbox 0;
open_box 2;
print_string "Expecting function has type";
print_space ();
type_expr ty;
close_box ();
print_cut ();
if l = "" then
print_string "This argument cannot be applied without label"
else
printf "This argument cannot be applied with label %s:" l;
close_box ()
| Label_multiply_defined lid ->
print_string "The label "; longident lid;
print_string " is defined several times"
@ -990,23 +1287,19 @@ let report_error = function
print_string " is not mutable"
| Not_subtype(tr1, tr2) ->
reset ();
List.iter
(function (t, t') -> mark_loops t; if t != t' then mark_loops t')
tr1;
List.iter
(function (t, t') -> mark_loops t; if t != t' then mark_loops t')
tr2;
let tr1 = List.map prepare_expansion tr1
and tr2 = List.map prepare_expansion tr2 in
trace true (fun _ -> print_string "is not a subtype of type") tr1;
trace false (fun _ -> print_string "is not compatible with type") tr2
| Outside_class ->
print_string "This object duplication occurs outside a method definition."
print_string "This object duplication occurs outside a method definition"
| Value_multiply_overridden v ->
print_string "The instance variable "; print_string v;
print_string " is overridden several times"
| Coercion_failure (ty, ty', trace) ->
unification_error true trace
(function () ->
mark_loops ty; if ty' != ty then mark_loops ty';
let ty, ty' = prepare_expansion (ty, ty') in
print_string "This expression cannot be coerced to type";
print_break 1 2;
type_expansion ty ty';
@ -1017,6 +1310,20 @@ let report_error = function
print_string "but is here used with type")
| Too_many_arguments ->
print_string "This function expects too many arguments"
| Abstract_wrong_label (l, ty) ->
reset (); mark_loops ty;
open_vbox 0;
open_box 2;
print_string "This function should have type";
print_space ();
type_expr ty;
close_box ();
print_cut ();
if l = "" then
print_string "but its argument is not labeled"
else
printf "but its argument is labeled %s:" l;
close_box ()
| Scoping_let_module(id, ty) ->
reset (); mark_loops ty;
print_string "This `let module' expression has type";

15
typing/typecore.mli
View File

@ -30,7 +30,7 @@ val type_let:
val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_class_arg_pattern:
string -> Env.t -> Env.t -> Parsetree.pattern ->
string -> Env.t -> Env.t -> label -> Parsetree.pattern ->
Typedtree.pattern * (Ident.t * Ident.t * type_expr) list *
Env.t * Env.t
val type_self_pattern:
@ -40,10 +40,17 @@ val type_self_pattern:
(Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
Env.t * Env.t * Env.t
val type_expect:
Env.t -> Parsetree.expression -> type_expr ->
Typedtree.expression
Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
val type_exp:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_approx:
Env.t -> Parsetree.expression -> type_expr
val type_argument:
Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
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
type error =
Unbound_value of Longident.t
@ -56,6 +63,7 @@ type error =
| Orpat_not_closed
| Expr_type_clash of (type_expr * type_expr) list
| Apply_non_function of type_expr
| Apply_wrong_label of label * type_expr
| Label_multiply_defined of Longident.t
| Label_missing
| Label_not_mutable of Longident.t
@ -71,6 +79,7 @@ type error =
| Value_multiply_overridden of string
| Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list
| Too_many_arguments
| Abstract_wrong_label of label * type_expr
| Scoping_let_module of string * type_expr
| Masked_instance_variable of Longident.t

Some files were not shown because too many files have changed in this diff Show More