diff options
110 files changed, 4507 insertions, 841 deletions
@@ -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 @@ -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 diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 4235aa177..78838150b 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -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) = diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 29e2bfadb..972de7d18 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -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 = diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 24cfad793..21def9eab 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -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 diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 3e0b521ce..a37ab2ac4 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -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 make_switch_or_test_sequence arg const_lambda_list int_lambda_list = +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_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 ()) diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 08f3d806a..7923282f0 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -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 diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 015784c85..7e632ed5e 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -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 diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 822123715..276c49b49 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -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 diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 89aa51983..46e2bb7f8 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -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 diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot index 06e342093..584031ec2 100755 --- a/config/auto-aux/hasgot +++ b/config/auto-aux/hasgot @@ -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 diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest index a5ca7bd4f..82f8f47d4 100755 --- a/config/auto-aux/runtest +++ b/config/auto-aux/runtest @@ -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 diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c new file mode 100644 index 000000000..ebd1224f0 --- /dev/null +++ b/config/auto-aux/tclversion.c @@ -0,0 +1,7 @@ +#include <stdio.h> +#include <tcl.h> + +main () +{ + puts(TCL_VERSION); +} @@ -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
\ No newline at end of file diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 2baa09092..ce235e701 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -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."; diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 2e547b5ab..c7ca0ee8a 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -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; diff --git a/driver/errors.ml b/driver/errors.ml index 05692afc3..25cb975ac 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -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) -> diff --git a/driver/main.ml b/driver/main.ml index 5a62c4be6..24eb6f2f9 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -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 diff --git a/driver/main_args.ml b/driver/main_args.ml index a4e68a270..7e19e95f5 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -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"; diff --git a/driver/main_args.mli b/driver/main_args.mli index c0f4f59f5..b453ebd38 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -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 diff --git a/driver/optmain.ml b/driver/optmain.ml index 67464df43..a410fb6a9 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -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; diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 1f1288815..f70e1eecd 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -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 diff --git a/man/ocaml.m b/man/ocaml.m index edcf881ba..f4e89c384 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -7,6 +7,9 @@ ocaml \- The Objective Caml interactive toplevel .SH SYNOPSIS .B ocaml [ +.B \-modern +] +[ .B \-unsafe ] [ @@ -51,6 +54,12 @@ 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) and s.[i] constructs). Programs compiled with diff --git a/man/ocamlc.m b/man/ocamlc.m index 2f25d54e4..23a9369ed 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -19,6 +19,9 @@ ocamlc \- The Objective Caml bytecode compiler .B \-custom ] [ +.B \-modern +] +[ .B \-unsafe ] [ @@ -228,6 +231,12 @@ option is given, specify the name of the library produced. 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 .B v.(i) diff --git a/man/ocamlopt.m b/man/ocamlopt.m index c15614102..72167483c 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -19,6 +19,9 @@ ocamlopt \- The Objective Caml native-code compiler .B \-compact ] [ +.B \-modern +] +[ .B \-unsafe ] [ @@ -217,6 +220,12 @@ is saved in the file 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 s.[i] constructs). Programs compiled with -unsafe are therefore diff --git a/otherlibs/db/db.mli b/otherlibs/db/db.mli index d919fa037..904e63647 100644 --- a/otherlibs/db/db.mli +++ b/otherlibs/db/db.mli @@ -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 diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli index 2667b3057..06600cc05 100644 --- a/otherlibs/dbm/dbm.mli +++ b/otherlibs/dbm/dbm.mli @@ -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. *) diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index 7bac5da02..d9cb2c013 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -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 diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli index 578774e98..fe13764a0 100644 --- a/otherlibs/graph/graphics.mli +++ b/otherlibs/graph/graphics.mli @@ -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). *) diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore index c55569311..385e7229c 100644 --- a/otherlibs/labltk/lib/.cvsignore +++ b/otherlibs/labltk/lib/.cvsignore @@ -1,3 +1,3 @@ -*.ml *.mli labltktop +*.ml *.mli labltktop labltk labltklink labltkopt modules .depend diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli index 73eabf969..dff91ed48 100644 --- a/otherlibs/str/str.mli +++ b/otherlibs/str/str.mli @@ -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]. *) diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli index 007d024b7..efd92569a 100644 --- a/otherlibs/systhreads/condition.mli +++ b/otherlibs/systhreads/condition.mli @@ -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. diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli index ede7f9bc4..082df6d10 100644 --- a/otherlibs/systhreads/event.mli +++ b/otherlibs/systhreads/event.mli @@ -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. *) diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index ce8b43590..e9d7cbf19 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -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. diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli index a3075e502..ebc90b4b9 100644 --- a/otherlibs/systhreads/threadUnix.mli +++ b/otherlibs/systhreads/threadUnix.mli @@ -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 diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli index 007d024b7..efd92569a 100644 --- a/otherlibs/threads/condition.mli +++ b/otherlibs/threads/condition.mli @@ -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. diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli index ede7f9bc4..082df6d10 100644 --- a/otherlibs/threads/event.mli +++ b/otherlibs/threads/event.mli @@ -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. *) diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 0ab38e447..5258d40fd 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -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 *) diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index e9838c28e..f2dedcb29 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -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. diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index ab09603c0..ddaa37f3d 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -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 diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index ce4153507..2f6ee69fa 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -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, diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index 00ea5c334..cd30e3b5a 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -29,3 +29,5 @@ type private_flag = Private | Public type mutable_flag = Immutable | Mutable type virtual_flag = Virtual | Concrete + +type label = string diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 212d7061a..24e59e121 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -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) } diff --git a/parsing/parser.mly b/parsing/parser.mly index e626868d0..6ba262ea6 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -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 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 94e61ab66..b6cf4f73c 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -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 diff --git a/parsing/printast.ml b/parsing/printast.ml index 8ead631ed..df30e7410 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -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; diff --git a/parsing/pstream.ml b/parsing/pstream.ml index c674751d5..6d9ba4a7d 100644 --- a/parsing/pstream.ml +++ b/parsing/pstream.ml @@ -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 diff --git a/stdlib/.depend b/stdlib/.depend index 766b0d23e..8a555275f 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -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 diff --git a/stdlib/Makefile b/stdlib/Makefile index ab86ed0e8..84f0cd0ce 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -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: diff --git a/stdlib/arg.mli b/stdlib/arg.mli index f50647e39..7f9739d3b 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -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 diff --git a/stdlib/array.mli b/stdlib/array.mli index d889d3a8d..9beb68082 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -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]. *) diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli index 5b8499502..8d205cca8 100644 --- a/stdlib/buffer.mli +++ b/stdlib/buffer.mli @@ -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]. *) diff --git a/stdlib/digest.mli b/stdlib/digest.mli index 83d48b1e9..2da4560db 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -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. *) diff --git a/stdlib/filename.mli b/stdlib/filename.mli index cf9c931e5..3cc7b41da 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -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 diff --git a/stdlib/format.mli b/stdlib/format.mli index 988e7bf63..a7c414c85 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -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. *) diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index a5adc958a..c89a8b12a 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -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) diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 1ee28e6a5..240f83a34 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -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 diff --git a/stdlib/list.mli b/stdlib/list.mli index 90ba1a2ca..0a6601fee 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -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. *) diff --git a/stdlib/map.mli b/stdlib/map.mli index de55d8489..cacae8d03 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -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. diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index 25e140d92..d55f175e5 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -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. diff --git a/stdlib/obj.mli b/stdlib/obj.mli index a09659654..fb9392efd 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -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 diff --git a/stdlib/oo.mli b/stdlib/oo.mli index c9ab18c1c..21df77d66 100644 --- a/stdlib/oo.mli +++ b/stdlib/oo.mli @@ -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] *) diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index b82edc1ae..5eb21549a 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -12,7 +12,7 @@ (* $Id$ *) -type 'a option = None | Some of 'a +(* type 'a option = None | Some of 'a *) (* Exceptions *) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 31347340e..73108775f 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -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. *) diff --git a/stdlib/queue.mli b/stdlib/queue.mli index 867915bd0..c569ae7dc 100644 --- a/stdlib/queue.mli +++ b/stdlib/queue.mli @@ -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. *) diff --git a/stdlib/set.mli b/stdlib/set.mli index cd0d6b97f..058a91146 100644 --- a/stdlib/set.mli +++ b/stdlib/set.mli @@ -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 diff --git a/stdlib/sort.mli b/stdlib/sort.mli index dd6abd2e7..413057090 100644 --- a/stdlib/sort.mli +++ b/stdlib/sort.mli @@ -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 diff --git a/stdlib/stack.mli b/stdlib/stack.mli index 38e42a623..7815657c7 100644 --- a/stdlib/stack.mli +++ b/stdlib/stack.mli @@ -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. *) diff --git a/stdlib/stream.mli b/stdlib/stream.mli index 20495ecbf..31454b570 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -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. *) diff --git a/stdlib/string.mli b/stdlib/string.mli index c7d0207be..36928a5ca 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -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" diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 39fb7e4a4..7583bb9e6 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -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" diff --git a/stdlib/weak.mli b/stdlib/weak.mli index 53c73e3ee..8b8b6b331 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -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. diff --git a/testlabl/dirs b/testlabl/dirs new file mode 100644 index 000000000..d7ca7b66c --- /dev/null +++ b/testlabl/dirs @@ -0,0 +1 @@ +asmcomp/linearize.ml asmcomp/spill.ml bytecomp debugger driver lex parsing stdlib testlabl tools toplevel typing utils diff --git a/testlabl/newlabels.ps b/testlabl/newlabels.ps new file mode 100644 index 000000000..01eac1945 --- /dev/null +++ b/testlabl/newlabels.ps @@ -0,0 +1,1458 @@ +%!PS-Adobe-2.0 +%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp) +%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com) +%%Title: newlabels.dvi +%%Pages: 2 0 +%%PageOrder: Ascend +%%BoundingBox: 0 0 596 842 +%%EndComments +%%BeginProcSet: PStoPS 1 15 +userdict begin +[/showpage/erasepage/copypage]{dup where{pop dup load + type/operatortype eq{1 array cvx dup 0 3 index cvx put + bind def}{pop}ifelse}{pop}ifelse}forall +[/letter/legal/executivepage/a4/a4small/b5/com10envelope + /monarchenvelope/c5envelope/dlenvelope/lettersmall/note + /folio/quarto/a5]{dup where{dup wcheck{exch{}put} + {pop{}def}ifelse}{pop}ifelse}forall +/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put} + {pop def}ifelse}{def}ifelse +/PStoPSmatrix matrix currentmatrix def +/PStoPSxform matrix def/PStoPSclip{clippath}def +/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def +/initmatrix{matrix defaultmatrix setmatrix}bind def +/initclip[{matrix currentmatrix PStoPSmatrix setmatrix + [{currentpoint}stopped{$error/newerror false put{newpath}} + {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse] + {[/newpath cvx{/moveto cvx}{/lineto cvx} + {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop} + stopped{$error/errorname get/invalidaccess eq{cleartomark + $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop + /initclip dup load dup type dup/operatortype eq{pop exch pop} + {dup/arraytype eq exch/packedarraytype eq or + {dup xcheck{exch pop aload pop}{pop cvx}ifelse} + {pop cvx}ifelse}ifelse + {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def +/initgraphics{initmatrix newpath initclip 1 setlinewidth + 0 setlinecap 0 setlinejoin []0 setdash 0 setgray + 10 setmiterlimit}bind def +end +%%EndProcSet +%DVIPSCommandLine: dvips -f newlabels +%DVIPSParameters: dpi=300 +%DVIPSSource: TeX output 1999.10.26:1616 +%%BeginProcSet: tex.pro +%! +/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N +/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 +mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} +ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale +isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div +hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul +TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if} +forall round exch round exch]setmatrix}N /@landscape{/isls true N}B +/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B +/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{ +/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N +string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N +end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{ +/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0] +N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup +length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{ +128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub +get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data +dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N +/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup +/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx +0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff +setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff +.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]} +if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup +length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{ +cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin +0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul +add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict +/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook +known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X +/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn +put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N +/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley +X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[ +(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup +length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse} +forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false +RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1 +false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform +round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg +rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail +{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M} +B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{ +4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{ +p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p +a}B /bos{/SS save N}B /eos{SS restore}B end + +%%EndProcSet +TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi) +@start +%DVIPSBitmapFont: Fa cmr6 6 2 +/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49 +D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F +8F0F> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fb cmmi8 8 4 +/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000 +40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830 +000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046 +0046008C000C0018001800180031003100320032001C0009177F960C> 105 +D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06 +00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109 +D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818 +80300980300E00120E7F8D15> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fc cmbx8 8 4 +/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007 +800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C +3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C +0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF +1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F +003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fd cmsy8 8 3 +/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80 +3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0 +0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0 +006040002013137E9218> 92 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fe cmtt12 12 43 +/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF +F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF +F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35 +D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1 +FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C +08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38 +D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0 +00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003 +C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0 +01C000E000E0007000700070003800380038003800380038003800380038003800700070 +007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0 +FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0 +01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0 +7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070 +F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00 +003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D +9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001 +E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000 +38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F +FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007 +FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E +03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070 +03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F +FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F +C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A> +I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I< +0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000 +FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0 +0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000 +007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F +C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000 +FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38 +01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000 +E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070 +1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070 +1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870 +1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0 +FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0 +E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070 +000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E +9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800 +003800003800003800003800003800003800003800003800003800003800003800003800 +00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF +FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0 +00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF +FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C +001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C +001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F +00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003 +80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00 +000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00 +380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF +C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070 +0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003 +FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0 +0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0 +E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A> +I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF +F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00 +07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000 +E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000 +E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000 +0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0 +0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC +FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000 +0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000 +00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80 +121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108 +D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C +001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C +007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F +00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E +00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0 +7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80 +1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00 +380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF +C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0 +007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003 +80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F +FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F +C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3 +F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0 +FFFFE0038000038000038000038000038000038000038000038000038000038000038070 +03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07 +E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00 +E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E +00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000 +EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038 +3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0 +0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383 +8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783 +C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007 +00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000 +6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F +C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0 +F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Ff cmr8 8 3 +/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000 +003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000 +00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E +000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49 +D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810 +183FF07FF0FFF00D157E9412> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fg cmmi12 12 13 +/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0 +0000C00000C00000C00001C0000180000180000380000380000380000700000300001615 +7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000 +004000000040000000800000008000000080000000800000010000000FE00000711C0001 +C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0 +080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001 +FE0000002000000020000000400000004000000040000000400000008000000080000000 +800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58 +D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000 +0300000300000600000600000600000C00000C00000C0000180000180000180000300000 +300000300000600000600000600000C00000C00000C00001800001800001800001800003 +00000300000300000600000600000600000C00000C00000C000018000018000018000030 +0000300000300000600000600000600000C00000C00000C0000011317DA418> 61 +D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00 +00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000 +0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000 +8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76 +D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780 +04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00 +00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800 +000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84 +D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000 +07800020000F000040000F000040000F000040000F000040001E000080001E000080001E +000080001E000080003C000100003C000100003C000100003C0001000078000200007800 +020000780002000078000200007000040000F000040000F0000800007000080000700010 +00007000200000380040000038008000001C01000000060600000001F800000021237DA1 +21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000 +E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417> +101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E +001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C +000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0 +0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E +000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418 +> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00 +001C00001C00001C00001C000038000038000038000038000070000030000012157E9416 +> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038 +0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C +> 120 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fh cmti12 12 22 +/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8 +C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E +00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97 +D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C +0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010 +237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000 +780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B +9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000 +E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807 +00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07 +8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000 +E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186 +000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00 +000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000 +00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000 +F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380 +700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07 +80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0 +003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E +002300430043008700870087000E000E001C001C001C0038003800384070807080708071 +0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001 +C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E +20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070 +3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380 +038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000 +700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047 +6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00 +E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380 +70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E +40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038 +0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180 +0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780 +700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878 +0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380 +7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00 +001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087 +00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038 +000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C +00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040 +08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF +F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070 +8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030 +8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080 +1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119 +D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0 +0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E +00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C +03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060 +1C00F03800F03000E0600080C0004380003E0000141F7B9418> I +E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fi cmbx12 12 20 +/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F +8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0 +07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807 +F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0 +000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E +A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006 +FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F +00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80 +18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003 +F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8 +00000003F800000003F800000003F800000003F800000003F800000003F800000003F800 +000003F800000003F800000003F800000003F800000003F800000003F800000003F80000 +0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022 +227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0 +03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F +18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000 +001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C +001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F +C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8 +00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000 +FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060 +07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00 +F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0 +7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1 +E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0 +0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0 +0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780 +1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000 +0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00 +3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00 +0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000 +00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00 +1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00 +1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108 +D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F +001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000 +FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00 +1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00 +1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00 +7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00 +F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00 +1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0 +1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000 +1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000 +FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F +E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF +FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007 +80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F +80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000 +F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E +001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E +001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0 +FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000 +001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00 +0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006 +000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860 +00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00 +00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000 +001F0000001B207F951E> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fj cmsy10 12 15 +/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F +FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F +FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000 +060000000C0000001800000030000000300000006000000060000000C0000000C0000000 +C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000 +30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A +27> 26 D<00000001800000000001800000000001800000000001800000000000C00000 +000000C000000000006000000000003000000000003000000000001C00000000000E0000 +0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000 +000000300000000000300000000000600000000000C00000000000C00000000001800000 +00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003 +80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF +FFFFC00000C000006000006000006000003000003000001800000C000006000003800001 +E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00 +00180000180000300000300000600000600000C00000C00000C000018000018000030000 +0300000600000600000C00000C0000180000180000300000300000600000600000C00000 +C0000180000180000300000300000300000600000600000C00000C000018000018000030 +0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0 +C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780 +3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070 +E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0 +7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E +A519> 59 D<000100000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000000300000003000000030000000300000003 +000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63 +D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 +C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 +C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006 +000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780 +78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000 +00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 +00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 +00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300 +0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030 +00030030000300300006001800060018000C000C000C000C000C000C0018000600180006 +003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94 +D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00 +00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E +000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0 +C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 +02317AA40E> 106 D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fk cmr12 12 65 +/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007 +003800070038000700380007003800070038000700380007003800FFFFFFC00700380007 +003800070038000700380007003800070038000700380007003800070038000700380007 +0038000700380007003800070038000700380007003800070038000700380007003C007F +E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800 +0700300007000000070000000700000007000000070000000700000007000000FFFFF800 +070078000700380007003800070038000700380007003800070038000700380007003800 +070038000700380007003800070038000700380007003800070038000700380007003800 +070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007 +0038000700380007003800070038000700380007003800070038000700380007003800FF +FFF800070038000700380007003800070038000700380007003800070038000700380007 +003800070038000700380007003800070038000700380007003800070038000700380007 +003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E +00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00 +0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0 +07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007 +001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700 +1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006 +0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000 +7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 +6000600060007000300030003000180018000C000C000400060003000100008000400020 +0B327CA413> I<800040002000100018000C000400060006000300030001800180018001 +C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 +C000C000C001C0018001800180030003000600060004000C00180010002000400080000B +327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44 +D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300 +3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0 +F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0 +3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003 +800380038003800380038003800380038003800380038003800380038003800380038003 +800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007 +002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003 +C0000780000700000E00001C0000180000300000600000C0000180000100000200200400 +200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020 +07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003 +F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0 +03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700 +000700000F00001700001700002700006700004700008700018700010700020700060700 +040700080700080700100700200700200700400700C00700FFFFF8000700000700000700 +000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000 +000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000 +0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126 +> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0 +00800080018001000100010001000100010000000000000000000000038007C007C007C0 +038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000 +05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000 +203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001 +000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E +0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0 +078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0 +07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8 +078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0 +0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007 +0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8 +000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078 +0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001 +C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780 +0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780 +003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780 +003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780 +03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000 +C00780004007800040078000600780002007800020078000200780202007802000078020 +0007802000078060000780E00007FFE0000780E000078060000780200007802000078020 +000780200007800000078000000780000007800000078000000780000007800000078000 +00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0 +01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800 +000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800 +1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700 +0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003 +F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001 +E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001 +E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001 +E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780 +078007800780078007800780078007800780078007800780078007800780078007800780 +07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80 +0FC0007C0007800030000780002000078000400007800080000780010000078002000007 +80040000078008000007801000000780200000078040000007808000000781C000000783 +E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E +000007800F000007800F00000780078000078007C000078003C000078001E000078001E0 +00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75 +D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00 +000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00 +010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E +> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C +0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400 +F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400 +03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125> +78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C +0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8 +00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C +0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000 +0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780 +03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780 +0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780 +0000078000000780000007800000078000000780000007800000078000000FC00000FFFC +00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780 +03C000078003E000078003E000078003E000078003E000078003E000078003C000078007 +C000078007800007800E000007803C000007FFE000000780700000078038000007801C00 +0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000 +07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000 +00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000 +60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F +C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000 +C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008 +4007800840078008C007800C800780048007800480078004800780040007800000078000 +000780000007800000078000000780000007800000078000000780000007800000078000 +000780000007800000078000000780000007800000078000000780000007800000078000 +00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80 +000C000780000800078000080003C000100003C000100003C000100001E000200001E000 +200001F000600000F000400000F000400000780080000078008000007C008000003C0100 +00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000 +000788000000078800000003D000000003D000000003F000000001E000000001E0000000 +00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F +0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003 +C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001 +E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000 +78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000 +1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000 +070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0 +C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE +FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606 +060606060606060606060606060606060606060606FEFE07317FA40E> 93 +D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07 +00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97 +D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00 +1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723 +7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0 +0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94 +16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0 +F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE +17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000 +00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315 +7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007 +0000070000070000070000FFF80007000007000007000007000007000007000007000007 +00000700000700000700000700000700000700000700000700000700000700000780007F +F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780 +7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0 +0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00 +15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00 +700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00 +70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000 +000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E +000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000 +00000000007007F000F00070007000700070007000700070007000700070007000700070 +00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F> +I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8 +000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723 +7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E +000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E +00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E +003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00 +3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038 +00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E +00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E +0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078 +F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700 +01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00 +1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F +000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B +> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0 +00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000 +00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F +0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0 +10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80 +0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00 +1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04 +0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E +00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006 +017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040 +0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800 +00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260 +100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C +8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F +00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000 +8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078 +1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200 +00E200007400007400003800003800003800001000001000002000002000002000004000 +F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E +00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00 +80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124 +D E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fl cmbx12 14.4 19 +/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000 +FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007 +7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF +00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80 +0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800 +003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8 +31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003 +FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC +00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00 +000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001 +C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80 +03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828> +76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000 +03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000 +007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000 +003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000 +003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000 +007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800 +07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C +A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380 +01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00 +003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000 +000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000 +0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000 +00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000 +00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000 +30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F +801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F +803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F +FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0 +00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0 +00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0 +007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0 +007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F +FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007 +F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007 +F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007 +F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007 +F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87 +FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00 +0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00 +0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0 +1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07 +F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007 +F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007 +F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018 +2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0 +00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1 +FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0 +07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0 +07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925> +104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF +E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F +E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0 +0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0 +0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE +0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007 +F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007 +F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F +FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80 +0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00 +03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80 +0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F +E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000 +7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000 +FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000 +000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00 +0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F +E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F +E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078 +00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800 +FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016 +1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000 +0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000 +0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070 +07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F +E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F +E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F +E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fm cmr12 14.4 20 +/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44 +D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0 +0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 +0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 +0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001 +F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000 +F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0 +000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628 +7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C +00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC +001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C +003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54 +D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800 +1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700 +9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00 +E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000 +1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80 +0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000 +0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000 +00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0 +3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000 +F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71 +D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03 +C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74 +D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780 +07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E +000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00 +00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000 +00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003 +C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000 +272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0 +000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0 +007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F +8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00 +00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00 +00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00 +01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00 +01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F +C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000 +F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008 +1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00 +E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800 +007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101 +D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0 +007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00 +0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C +0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E +0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00 +1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00 +0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0 +0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E +F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C +1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300 +0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00 +F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00 +1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00 +00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99 +1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F +00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F +00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080 +E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0 +8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080 +000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780 +000780000780000780000780000780000780000780000780000780000780000780000780 +0007804007804007804007804007804007804007804003C08001C08000E100003E001225 +7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F +000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F +000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F +F01C1A7E9921> I E +%EndDVIPSBitmapFont +%DVIPSBitmapFont: Fn cmr17 20.74 18 +/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000 +03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8 +0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000 +000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000 +0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000 +0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000 +00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000 +FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F +0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0 +00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000 +00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000 +01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00 +0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001 +F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001 +F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001 +F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001 +F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001 +F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001 +F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001 +F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001 +F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001 +F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF +FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000 +03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8 +0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000 +00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000 +0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000 +01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001 +FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC +FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F +0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80 +00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000 +00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000 +01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0 +0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E +00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0 +001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000 +01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E +0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00 +0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97 +D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000 +03E000000003E000000003E000000003E000000003E000000003E000000003E000000003 +E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0 +00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800 +03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000 +7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E +03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803 +E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383 +001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0 +03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000 +7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000 +FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018 +0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000 +3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E +00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC +000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F +0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F +257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0 +00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB +18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000 +0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0 +000380000000000000000000000000000000000000000000000000000000000000000000 +0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF +C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 +C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E +01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00 +03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 +C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 +07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000 +FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003 +F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0 +0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000 +07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007 +C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF +28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C +000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0 +7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC +000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00 +000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001 +C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003 +E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003 +E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 +E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 +E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114 +D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006 +00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0 +0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003 +80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070 +00807F800019257DA41F> I<003000000030000000300000003000000030000000300000 +0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000 +07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 +01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180 +01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400 +000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003 +E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C +000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80 +3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0 +000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000 +00003C000000003C000000003C0000000018000028257FA42A> 118 +D E +%EndDVIPSBitmapFont +end +%%EndProlog +%%BeginSetup +%%Feature: *Resolution 300dpi +TeXDict begin +%%PaperSize: a4 + +userdict/PStoPSxform PStoPSmatrix matrix currentmatrix + matrix invertmatrix matrix concatmatrix + matrix invertmatrix put +%%EndSetup +%%Page: (0,1) 1 +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 0.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +/showpage{}def/copypage{}def/erasepage{}def +PStoPSxform concat +1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p +927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404 +370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719 +634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p +Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p +319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929 +a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101 +929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p +Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073 +a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p +259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687 +1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p +1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360 +1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280 +a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459 +1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p +878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m +(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p +1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p +303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p +681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p +1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340 +a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p +1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p +322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk +133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502 +a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p +918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84 +1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p +492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p +891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p +Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838 +a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594 +1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p +991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301 +1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p +Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg +634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579 +2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004 +a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p +Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p +Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391 +2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p +656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh +634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p +Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p +Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p +Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245 +a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245 +a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj +579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305 +a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p +Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p +Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365 +a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p +Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p +Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365 +a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p +Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p +634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634 +2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182 +2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p +Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634 +2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p +Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p +Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh +956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop +PStoPSsaved restore +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 421.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +PStoPSxform concat +2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p +Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141 +261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495 +261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p +Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227 +366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p +Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366 +a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366 +a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p +Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p +Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p +Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427 +a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk +790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p +877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936 +434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010 +427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108 +427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185 +427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289 +427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427 +a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408 +427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p +Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487 +a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p +Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p +Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p +551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610 +494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671 +494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p +Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p +Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p +Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p +Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020 +547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p +Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p +Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p +Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p +Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547 +a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554 +a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p +Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p +Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607 +a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk +451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p +538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597 +614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p +Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614 +a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417 +607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588 +607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p +1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc +1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579 +667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p +Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p +Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p +945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk +1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728 +a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246 +728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p +Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p +Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p +555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk +629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk +698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p +Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735 +a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999 +728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061 +728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p +Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p +Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728 +a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735 +a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p +Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p +Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788 +a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788 +a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p +1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p +Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p +Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p +Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848 +a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk +470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p +557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616 +855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688 +855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772 +855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848 +a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000 +848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060 +855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p +Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p +Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p +Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848 +a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855 +a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p +Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908 +a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi +906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p +Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p +1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p +Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p +Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p +240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p +685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127 +a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127 +a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11 +1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187 +a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187 +a(original) p 764 1187 a(comfort) p 949 1187 a(of) p +1009 1187 a(out-of-order) p 1283 1187 a(application) p +1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814 +1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p +431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p +1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p +1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626 +1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p +Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308 +a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p +Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p +355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519 +1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p +884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210 +1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p +1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11 +1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605 +a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p +728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p +1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p +1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605 +a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p +184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p +440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620 +1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184 +1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440 +1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839 +a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p +363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568 +1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p +927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p +312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491 +1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p +902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235 +2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020 +a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020 +a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p +312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491 +2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p +927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184 +2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140 +a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p +722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184 +2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200 +a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133 +2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260 +a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p +645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321 +a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p +543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p +850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p +1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p +1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p +261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p +204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555 +a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555 +a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138 +2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462 +2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555 +a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p +Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615 +a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270 +2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p +547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p +850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p +1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515 +2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11 +2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p +310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p +718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p +Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p +1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p +1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p +153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p +477 2796 a(principal.) 926 2937 y(2) p eop +PStoPSsaved restore +%%Page: (2,3) 2 +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 0.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +/showpage{}def/copypage{}def/erasepage{}def +PStoPSxform concat +3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p +382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p +684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p +1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p +1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p +Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p +183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p +759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p +1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p +1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p +1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p +463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289 +a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p +1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p +1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p +1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p +181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p +581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p +Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571 +a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p +466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p +1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p +1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753 +571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p +199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p +472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631 +a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631 +a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p +1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p +1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p +1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p +403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p +694 692 a(from) p 809 692 a(constructors) p 1086 692 +a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692 +a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p +307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p +702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752 +a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204 +752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p +1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p +1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o +(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p +952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff +252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327 +939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939 +a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932 +a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585 +932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932 +a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p +797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932 +a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939 +a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p +Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127 +939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184 +944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p +Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939 +a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450 +939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525 +939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633 +939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042 +a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042 +a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o +(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042 +a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547 +1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p +1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p +214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162 +y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399 +1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p +145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p +460 1222 a(structural) p 685 1222 a(constrain) o(ts) p +934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p +1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222 +a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746 +1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p +Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p +418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p +Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p +967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282 +a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p +Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282 +a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p +365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p +833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p +1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515 +1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11 +1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p +417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p +646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015 +1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p +1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249 +1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p +Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p +Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p +753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p +Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509 +a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629 +a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629 +a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p +Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p +Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757 +1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629 +a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629 +a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p +372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p +Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p +Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p +Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p +Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689 +a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p +1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p +Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689 +a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689 +a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb +1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p +Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796 +a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796 +a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p +1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366 +1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p +1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p +211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p +Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856 +a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p +908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856 +a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469 +1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986 +a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p +188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p +458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078 +a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p +1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551 +2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11 +2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p +290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138 +a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244 +a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh +904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p +Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365 +a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p +Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120 +2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234 +2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496 +2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p +907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531 +a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531 +a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146 +2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p +466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926 +2937 y(3) p eop +PStoPSsaved restore +userdict/PStoPSsaved save put +PStoPSmatrix setmatrix +595.000000 421.271378 translate +90 rotate +0.706651 dup scale +userdict/PStoPSmatrix matrix currentmatrix put +userdict/PStoPSclip{0 0 moveto + 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto + closepath}put initclip +PStoPSxform concat +4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p +133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p +436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p +907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p +1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688 +261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p +266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p +909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p +1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p +1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772 +321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p +325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p +666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p +926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381 +a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p +1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p +1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441 +a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496 +441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p +881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501 +y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p +512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p +810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk +133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p +482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715 +616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p +1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p +1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133 +676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p +311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563 +676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p +979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p +272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579 +777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865 +777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p +1200 777 a(extension,) p 1426 777 a(simpli\014cation) p +1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p +310 838 a(|marking) p 551 838 a(constructors) p 830 838 +a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p +1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p +1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p +536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p +1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197 +898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898 +a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p +244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637 +958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p +1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958 +a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669 +958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p +469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772 +1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p +1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018 +a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018 +a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84 +1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516 +1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p +922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193 +a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515 +1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193 +a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p +363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253 +a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p +1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p +1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p +Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p +380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p +678 1490 a(other) p 812 1490 a(features:) p 1029 1490 +a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521 +1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11 +1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p +394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p +692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p +978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550 +a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550 +a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p +191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p +647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p +1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p +1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11 +1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p +283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p +603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y) +l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730 +a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p +845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p +1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730 +a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791 +y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p +482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791 +a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p +1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791 +a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926 +2937 y(4) p eop +PStoPSsaved restore +%%Trailer +end +userdict /end-hook known{end-hook}if +%%EOF diff --git a/testlabl/tests.ml b/testlabl/tests.ml new file mode 100644 index 000000000..a37fefda7 --- /dev/null +++ b/testlabl/tests.ml @@ -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" diff --git a/tools/.cvsignore b/tools/.cvsignore index 61be471d9..18bf4db28 100644 --- a/tools/.cvsignore +++ b/tools/.cvsignore @@ -11,3 +11,6 @@ ocamlmktop primreq ocamldumpobj keywords +ocaml2to3.ml +ocaml2to3 + diff --git a/tools/ocaml2to3.mll b/tools/ocaml2to3.mll new file mode 100644 index 000000000..5d30cdd3b --- /dev/null +++ b/tools/ocaml2to3.mll @@ -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 + +} diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 173b2ddd7..65202ac22 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -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" diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index c55c9e640..cb71aeca2 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -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) -> diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 409a6fc71..aa00c6267 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -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 diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index e2e73ae48..1fb94e064 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -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" diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 06057e7f8..a9c08dcaa 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -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; diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index c7949087e..acfa97a60 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -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"; diff --git a/toplevel/trace.ml b/toplevel/trace.ml index 92f6544e3..bfc657b52 100644 --- a/toplevel/trace.ml +++ b/toplevel/trace.ml @@ -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 diff --git a/typing/btype.ml b/typing/btype.ml index 420f9ad4e..1a700b5af 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -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 diff --git a/typing/btype.mli b/typing/btype.mli index 01477620e..e74c28c43 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -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 *) diff --git a/typing/ctype.ml b/typing/ctype.ml index 8b2212381..28469234e 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -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,8 +294,35 @@ 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)); diff --git a/typing/ctype.mli b/typing/ctype.mli index b6185ac24..948c68f51 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -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 diff --git a/typing/env.ml b/typing/env.ml index 21ea31197..ab31e46b9 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -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 diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 8a76b6f74..dd8b26391 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -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) diff --git a/typing/parmatch.mli b/typing/parmatch.mli index 76da023d2..157b91dae 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -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 diff --git a/typing/predef.ml b/typing/predef.ml index d4d5a3566..358ca96d7 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -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)) diff --git a/typing/predef.mli b/typing/predef.mli index c72680a7a..88becfa8e 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -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 diff --git a/typing/printtyp.ml b/typing/printtyp.ml index a4293241f..c5bf7342d 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -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 diff --git a/typing/printtyp.mli b/typing/printtyp.mli index f53860fe2..80daa2d9e 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -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 -> diff --git a/typing/subst.ml b/typing/subst.ml index 7b3771dce..95b9558ed 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -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 = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 9e12b3a7b..98d3cb217 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -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 *) diff --git a/typing/typeclass.mli b/typing/typeclass.mli index acd3cda9b..de5e92bd1 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -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 diff --git a/typing/typecore.ml b/typing/typecore.ml index d35a59206..1a54ff514 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -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 -> + | 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 with Unify _ -> - raise(Error(sexp.pexp_loc, Too_many_arguments)) + 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"; diff --git a/typing/typecore.mli b/typing/typecore.mli index fc0633cc6..38238ce98 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -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 diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 2dbb708a6..af4af2bc2 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -33,10 +33,13 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list + | Tpat_variant of label * pattern option * row_desc | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list | Tpat_or of pattern * pattern +type partial = Partial | Total + type expression = { exp_desc: expression_desc; exp_loc: Location.t; @@ -47,12 +50,13 @@ and expression_desc = Texp_ident of Path.t * value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list - | Texp_apply of expression * expression list - | Texp_match of expression * (pattern * expression) list + | Texp_function of (pattern * expression) list * partial + | Texp_apply of expression * expression option list + | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list | Texp_construct of constructor_description * expression list + | Texp_variant of label * expression option | Texp_record of (label_description * expression) list * expression option | Texp_field of expression * label_description | Texp_setfield of expression * label_description * expression @@ -84,8 +88,8 @@ and class_expr = and class_expr_desc = Tclass_ident of Path.t | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr - | Tclass_apply of class_expr * expression list + | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial + | Tclass_apply of class_expr * expression option list | Tclass_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list * class_expr | Tclass_constraint of class_expr * string list * string list * Concr.t @@ -151,6 +155,7 @@ let rec bound_idents pat = | Tpat_constant cst -> () | Tpat_tuple patl -> List.iter bound_idents patl | Tpat_construct(cstr, patl) -> List.iter bound_idents patl + | Tpat_variant(_, pat, _) -> may bound_idents pat | Tpat_record lbl_pat_list -> List.iter (fun (lbl, pat) -> bound_idents pat) lbl_pat_list | Tpat_array patl -> List.iter bound_idents patl diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 905607a77..f588c54dd 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -32,10 +32,13 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list + | Tpat_variant of label * pattern option * row_desc | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list | Tpat_or of pattern * pattern +type partial = Partial | Total + type expression = { exp_desc: expression_desc; exp_loc: Location.t; @@ -46,12 +49,13 @@ and expression_desc = Texp_ident of Path.t * value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression - | Texp_function of (pattern * expression) list - | Texp_apply of expression * expression list - | Texp_match of expression * (pattern * expression) list + | Texp_function of (pattern * expression) list * partial + | Texp_apply of expression * expression option list + | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list | Texp_construct of constructor_description * expression list + | Texp_variant of label * expression option | Texp_record of (label_description * expression) list * expression option | Texp_field of expression * label_description | Texp_setfield of expression * label_description * expression @@ -83,8 +87,8 @@ and class_expr = and class_expr_desc = Tclass_ident of Path.t | Tclass_structure of class_structure - | Tclass_fun of pattern * (Ident.t * expression) list * class_expr - | Tclass_apply of class_expr * expression list + | Tclass_fun of pattern * (Ident.t * expression) list * class_expr * partial + | Tclass_apply of class_expr * expression option list | Tclass_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list * class_expr | Tclass_constraint of class_expr * string list * string list * Concr.t diff --git a/typing/types.ml b/typing/types.ml index 7d1a6cf89..e8c49a142 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -26,13 +26,27 @@ type type_expr = and type_desc = Tvar - | Tarrow of type_expr * type_expr + | Tarrow of label * type_expr * type_expr | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr + | Tsubst of type_expr + | Tvariant of row_desc + +and row_desc = + { row_fields: (label * row_field) list; + row_more: type_expr; + row_bound: type_expr list; + row_closed: bool; + row_name: (Path.t * type_expr list) option } + +and row_field = + Rpresent of type_expr option + | Reither of bool * type_expr list * row_field option ref + | Rabsent and abbrev_memo = Mnil @@ -119,7 +133,7 @@ module Concr = Set.Make(OrderedString) type class_type = Tcty_constr of Path.t * type_expr list * class_type | Tcty_signature of class_signature - | Tcty_fun of type_expr * class_type + | Tcty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; diff --git a/typing/types.mli b/typing/types.mli index ef1e05e41..e20c17c04 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -25,13 +25,28 @@ type type_expr = and type_desc = Tvar - | Tarrow of type_expr * type_expr + | Tarrow of label * type_expr * type_expr | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr + | Tsubst of type_expr (* for copying *) + | Tvariant of row_desc + +and row_desc = + { row_fields: (label * row_field) list; + row_more: type_expr; + row_bound: type_expr list; + row_closed: bool; + row_name: (Path.t * type_expr list) option } + +and row_field = + Rpresent of type_expr option + | Reither of bool * type_expr list * row_field option ref + (* true denotes a constant constructor *) + | Rabsent and abbrev_memo = Mnil @@ -117,7 +132,7 @@ module Concr : Set.S with type elt = string type class_type = Tcty_constr of Path.t * type_expr list * class_type | Tcty_signature of class_signature - | Tcty_fun of type_expr * class_type + | Tcty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; diff --git a/typing/typetexp.ml b/typing/typetexp.ml index fdc98f1f2..e1cb50df3 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -31,13 +31,15 @@ type error = | Unbound_row_variable of Longident.t | Type_mismatch of (type_expr * type_expr) list | Alias_type_mismatch of (type_expr * type_expr) list + | Present_has_conjunction of string + | Present_has_no_type of string + | Multiple_constructor of string exception Error of Location.t * error (* Translation of type expressions *) let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) -let aliases = ref (Tbl.empty : (string, type_expr) Tbl.t) let saved_type_variables = ref ([] : (string, type_expr) Tbl.t list) let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) @@ -79,9 +81,9 @@ type policy = Fixed | Extensible | Delayed let rec transl_type env policy styp = match styp.ptyp_desc with - Ptyp_any -> new_global_var() + Ptyp_any -> Ctype.newvar () | Ptyp_var name -> - begin try Tbl.find name !aliases with Not_found -> + begin match policy with Fixed -> begin try @@ -113,10 +115,10 @@ let rec transl_type env policy styp = v end end - | Ptyp_arrow(st1, st2) -> + | Ptyp_arrow(l, st1, st2) -> let ty1 = transl_type env policy st1 in let ty2 = transl_type env policy st2 in - newty (Tarrow(ty1, ty2)) + newty (Tarrow(l, ty1, ty2)) | Ptyp_tuple stl -> newty (Ttuple(List.map (transl_type env policy) stl)) | Ptyp_constr(lid, stl) -> @@ -144,48 +146,122 @@ let rec transl_type env policy styp = cstr | Ptyp_object fields -> newobj (transl_fields env policy fields) - | Ptyp_class(lid, stl) -> + | Ptyp_class(lid, stl, present) -> if policy = Fixed then raise(Error(styp.ptyp_loc, Unbound_row_variable lid)); - let lid2 = - match lid with - Longident.Lident s -> Longident.Lident ("#" ^ s) - | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) - | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" - in - let (path, decl) = + let (path, decl, is_variant) = try - Env.lookup_type lid2 env + let (path, decl) = Env.lookup_type lid env in + match decl.type_manifest with + None -> raise Not_found + | Some ty -> + match (repr ty).desc with + Tvariant row when Btype.static_row row -> (path, decl, true) + | _ -> raise Not_found + with Not_found -> try + if present <> [] then raise Not_found; + let lid2 = + match lid with + Longident.Lident s -> Longident.Lident ("#" ^ s) + | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) + | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" + in + let (path, decl) = Env.lookup_type lid2 env in + (path, decl, false) with Not_found -> - raise(Error(styp.ptyp_loc, Unbound_class lid)) in + raise(Error(styp.ptyp_loc, Unbound_class lid)) + in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in + let cstr = newty (Tconstr(path, args, ref Mnil)) in let ty = - try - Ctype.expand_head env (newty (Tconstr(path, args, ref Mnil))) + try Ctype.expand_head env cstr with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) in let params = Ctype.instance_list decl.type_params in List.iter2 (fun (sty, ty') ty -> - try unify env ty ty' with Unify trace -> + try unify env ty' ty with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch trace))) (List.combine stl args) params; - ty + begin match ty.desc with + Tvariant row -> + let row = Btype.row_repr row in + List.iter + (fun l -> if not (List.mem_assoc l row.row_fields) then + raise(Error(styp.ptyp_loc, Present_has_no_type l))) + present; + let bound = ref row.row_bound in + let fields = + List.map + (fun (l,f) -> l, + if List.mem l present then f else + match Btype.row_field_repr f with + | Rpresent (Some ty) -> + bound := ty :: !bound; + Reither(false, [ty], ref None) + | Rpresent None -> + Reither (true, [], ref None) + | _ -> f) + row.row_fields + in + let row = { row with row_fields = fields; row_bound = !bound; + row_name = Some (path, args) } in + newty (Tvariant row) + | _ -> + ty + end | Ptyp_alias(st, alias) -> - if Tbl.mem alias !type_variables || Tbl.mem alias !aliases then + if Tbl.mem alias !type_variables then raise(Error(styp.ptyp_loc, Bound_type_variable alias)) else - let ty' = newvar () in - aliases := Tbl.add alias ty' !aliases; + let ty' = new_global_var () in + type_variables := Tbl.add alias ty' !type_variables; let ty = transl_type env policy st in begin try unify env ty ty' with Unify trace -> raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; ty + | Ptyp_variant(fields, closed, present) -> + let bound = ref [] in + ignore (List.fold_left + (fun (ll,hl) (l,_,_) -> + if List.mem l ll then + raise(Error(styp.ptyp_loc, Multiple_constructor l)); + let h = Btype.hash_variant l in + if List.mem h hl then + raise(Ctype.Tags(l, List.assoc h (List.combine hl ll))); + (l::ll, h::hl)) + ([],[]) + fields); + let fields = + List.map + (fun (l, c, stl) -> + l, if List.mem l present then begin + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, Present_has_conjunction l)); + match stl with [] -> Rpresent None + | st::_ -> Rpresent(Some(transl_type env policy st)) + end else begin + let tl = List.map (transl_type env policy) stl in + bound := tl @ !bound; + Reither(c, tl, ref None) + end) + fields + in + List.iter + (fun l -> if not (List.mem_assoc l fields) then + raise(Error(styp.ptyp_loc, Present_has_no_type l))) + present; + let row = + { row_fields = fields; row_more = newvar (); + row_bound = !bound; row_closed = closed; row_name = None } in + if policy = Fixed && not (Btype.static_row row) then + raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]")); + newty (Tvariant row) and transl_fields env policy = function @@ -193,7 +269,7 @@ and transl_fields env policy = newty Tnil | {pfield_desc = Pfield_var} as field::_ -> if policy = Fixed then - raise(Error(field.pfield_loc, Unbound_type_variable "..")); + raise(Error(field.pfield_loc, Unbound_type_variable "<..>")); newvar () | {pfield_desc = Pfield(s, e)}::l -> let ty1 = transl_type env policy e in @@ -201,18 +277,14 @@ and transl_fields env policy = newty (Tfield (s, Fpresent, ty1, ty2)) let transl_simple_type env fixed styp = - aliases := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in - aliases := Tbl.empty; typ let transl_simple_type_delayed env styp = - aliases := Tbl.empty; used_variables := Tbl.empty; bindings := []; let typ = transl_type env Delayed styp in let b = !bindings in - aliases := Tbl.empty; used_variables := Tbl.empty; bindings := []; (typ, @@ -269,3 +341,9 @@ let report_error = function print_string "This alias is bound to type") (function () -> print_string "but is used as an instance of type") + | Present_has_conjunction l -> + printf "The present constructor %s has a conjunctive type" l + | Present_has_no_type l -> + printf "The present constructor %s has no type" l + | Multiple_constructor l -> + printf "The variant constructor %s is multiply defined" l diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 4fc35175e..83791e123 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -40,6 +40,9 @@ type error = | Unbound_row_variable of Longident.t | Type_mismatch of (Types.type_expr * Types.type_expr) list | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list + | Present_has_conjunction of string + | Present_has_no_type of string + | Multiple_constructor of string exception Error of Location.t * error diff --git a/utils/clflags.ml b/utils/clflags.ml index f4be1aaa1..3104a0981 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -30,6 +30,7 @@ and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) and ccopts = ref ([] : string list) (* -ccopt *) +and classic = ref true (* -modern *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) and thread_safe = ref false (* -thread *) diff --git a/utils/config.mlp b/utils/config.mlp index ce4286c28..5547164ec 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,7 +12,7 @@ (* $Id$ *) -let version = "2.04+1" +let version = "2.99 (99/11/30)" let standard_library = try @@ -28,7 +28,7 @@ let c_libraries = "%%CCLIBS%%" let ranlib = "%%RANLIBCMD%%" let exec_magic_number = "Caml1999X004" -and cmi_magic_number = "Caml1999I004" +and cmi_magic_number = "Caml1999I005" and cmo_magic_number = "Caml1999O004" and cma_magic_number = "Caml1999A004" and cmx_magic_number = "Caml1999Y006" diff --git a/utils/misc.ml b/utils/misc.ml index 79560e80e..529484692 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -54,6 +54,16 @@ let rec list_remove x = function | hd :: tl -> if hd = x then tl else hd :: list_remove x tl +(* Options *) + +let may f = function + Some x -> f x + | None -> () + +let may_map f = function + Some x -> Some (f x) + | None -> None + (* File functions *) let find_in_path path name = diff --git a/utils/misc.mli b/utils/misc.mli index f0bc9ed57..969e97818 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -30,6 +30,9 @@ val list_remove: 'a -> 'a list -> 'a list (* [list_remove x l] returns a copy of [l] with the first element equal to [x] removed *) +val may: ('a -> unit) -> 'a option -> unit +val may_map: ('a -> 'b) -> 'a option -> 'b option + val find_in_path: string list -> string -> string (* Search a file in a list of directories. *) val remove_file: string -> unit |