diff --git a/Makefile.shared b/Makefile.shared index c0e3c6d54..05fb0408d 100755 --- a/Makefile.shared +++ b/Makefile.shared @@ -22,7 +22,7 @@ include stdlib/StdlibModules CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A \ +COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 -warn-error A \ -bin-annot -safe-string -strict-formats $(INCLUDES) LINKFLAGS= diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml index 73bd903db..45e32baf0 100644 --- a/asmcomp/CSEgen.ml +++ b/asmcomp/CSEgen.ml @@ -197,7 +197,7 @@ let remove_load_numbering n = let kill_addr_regs n = { n with num_reg = - Reg.Map.filter (fun r n -> r.Reg.typ <> Cmm.Addr) n.num_reg } + Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg } (* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) @@ -207,7 +207,7 @@ let insert_move srcs dsts i = match Array.length srcs with | 0 -> i | 1 -> instr_cons (Iop Imove) srcs dsts i - | l -> (* Parallel move: first copy srcs into tmps one by one, + | _ -> (* Parallel move: first copy srcs into tmps one by one, then copy tmps into dsts one by one *) let tmps = Reg.createv_like srcs in let i1 = array_fold2 insert_single_move i tmps dsts in diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml index d85e1629b..10066e4b5 100644 --- a/asmcomp/amd64/CSE.ml +++ b/asmcomp/amd64/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index a38e9ad55..a61d70684 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -73,11 +73,11 @@ let offset_addressing addr delta = | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 3f18d50d6..d3f940f72 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -31,13 +31,6 @@ let win64 = | "win64" | "mingw64" | "cygwin" -> true | _ -> false -(* Which asm conventions to use *) - -let masm = - match Config.ccomp_type with - | "msvc" -> true - | _ -> false - (* Registers available for register allocation *) (* Register map: @@ -138,7 +131,6 @@ let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let rax = phys_reg 0 -let rcx = phys_reg 5 let rdx = phys_reg 4 let rbp = phys_reg 12 let rxmm15 = phys_reg 115 @@ -181,14 +173,14 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let loc_arguments arg = calling_conventions 0 9 100 109 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc + let (loc, _ofs) = calling_conventions 0 9 100 109 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc (* C calling conventions under Unix: first integer args in rdi, rsi, rdx, rcx, r8, r9 @@ -204,7 +196,7 @@ let loc_results res = Return value in rax or xmm0. *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let unix_loc_external_arguments arg = calling_conventions 2 7 100 107 outgoing arg @@ -253,7 +245,7 @@ let loc_exn_bucket = rax (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 9ea80d066..f5140faa6 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -103,7 +103,7 @@ method! reload_operation op arg res = method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 3c1a344ec..aed087b70 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -138,7 +138,7 @@ method! is_simple_expr e = | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method select_addressing _chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) if d < -0x8000_0000 || d > 0x7FFF_FFFF @@ -175,7 +175,7 @@ method! select_operation op args = (* Recognize the LEA instruction *) Caddi | Caddv | Cadda | Csubi -> begin match self#select_addressing Word_int (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args + (Iindexed _, _) | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml index 3ab5a35d7..22ead1228 100644 --- a/asmcomp/arm/CSE.ml +++ b/asmcomp/arm/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index 72f88a052..fae300c61 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -157,7 +157,7 @@ let identity_addressing = Iindexed 0 let offset_addressing (Iindexed n) delta = Iindexed(n + delta) -let num_args_addressing (Iindexed n) = 1 +let num_args_addressing (Iindexed _) = 1 (* Printing operations and addressing modes *) diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 1d3ab6455..8a3909251 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -175,7 +175,7 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r7 @@ -224,7 +224,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index c89d628a6..9d847d4ce 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -19,7 +19,7 @@ open Mach (* Instruction scheduling for the ARM *) -class scheduler = object(self) +class scheduler = object inherit Schedgen.scheduler_generic as super diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index d363c556d..1be5026d4 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -53,7 +53,6 @@ exception Use_default let r1 = phys_reg 1 let r6 = phys_reg 6 let r7 = phys_reg 7 -let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = match op with diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml index 7a8fc17f1..c727e1e99 100644 --- a/asmcomp/arm64/CSE.ml +++ b/asmcomp/arm64/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml index 5c13957fe..fa40f2537 100644 --- a/asmcomp/arm64/arch.ml +++ b/asmcomp/arm64/arch.ml @@ -15,8 +15,6 @@ (* *) (**************************************************************************) -let command_line_options = [] - (* Specific operations for the ARM processor, 64-bit mode *) open Format @@ -81,8 +79,8 @@ let offset_addressing addr delta = | Ibased(s, n) -> Ibased(s, n + delta) let num_args_addressing = function - | Iindexed n -> 1 - | Ibased(s, n) -> 0 + | Iindexed _ -> 1 + | Ibased _ -> 0 (* Printing operations and addressing modes *) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 9cca60b26..a77422e53 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -36,7 +36,6 @@ let reg_trap_ptr = phys_reg 23 let reg_alloc_ptr = phys_reg 24 let reg_alloc_limit = phys_reg 25 let reg_tmp1 = phys_reg 26 -let reg_tmp2 = phys_reg 27 let reg_x15 = phys_reg 15 (* Output a label *) @@ -362,7 +361,7 @@ let num_call_gc_and_check_bound_points instr = in loop instr (0, 0) -let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound = +let max_out_of_line_code_offset ~num_call_gc ~num_check_bound = if num_call_gc < 1 && num_check_bound < 1 then 0 else begin let size_of_call_gc = 2 in @@ -606,7 +605,7 @@ let emit_instr i = let dst = i.res.(0) in let base = match addr with - | Iindexed ofs -> i.arg.(0) + | Iindexed _ -> i.arg.(0) | Ibased(s, ofs) -> ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; reg_tmp1 in @@ -633,7 +632,7 @@ let emit_instr i = let src = i.arg.(0) in let base = match addr with - | Iindexed ofs -> i.arg.(1) + | Iindexed _ -> i.arg.(1) | Ibased(s, ofs) -> ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; reg_tmp1 in @@ -905,7 +904,7 @@ let fundecl fundecl = num_call_gc_and_check_bound_points fundecl.fun_body in let max_out_of_line_code_offset = - max_out_of_line_code_offset fundecl.fun_body ~num_call_gc + max_out_of_line_code_offset ~num_call_gc ~num_check_bound in BR.relax fundecl.fun_body ~max_out_of_line_code_offset; diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index 86cfb51ed..f4cdeffa4 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -135,7 +135,7 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r15 @@ -171,7 +171,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index d7d55a938..dba3ae2d5 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -76,10 +76,6 @@ let rec run_automata nbits state input = let is_logical_immediate n = n <> 0 && n <> -1 && run_automata 64 0 n -let is_intconst = function - Cconst_int _ -> true - | _ -> false - let inline_ops = [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 254dec7b8..0184b5d06 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -135,7 +135,7 @@ let is_required name = try ignore (Hashtbl.find missing_globals name); true with Not_found -> false -let add_required by (name, crc) = +let add_required by (name, _crc) = try let rq = Hashtbl.find missing_globals name in rq := by :: !rq diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 9ecebef85..a7087c229 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -99,10 +99,7 @@ let make_package_object ppf members targetobj targetname coercion let source_provenance = Timings.Pack targetname in let prefixname = chop_extension_if_any objtemp in if Config.flambda then begin - let size, lam = - Translmod.transl_package_flambda - components module_ident coercion - in + let size, lam = Translmod.transl_package_flambda components coercion in let flam = Middle_end.middle_end ppf ~source_provenance @@ -150,7 +147,7 @@ let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in let filter lst = - List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in + List.filter (fun (name, _crc) -> not (List.mem name unit_names)) lst in let union lst = List.fold_left (List.fold_left diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 673bf8c84..4e61b95e5 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -124,7 +124,7 @@ let rec compare_float_lists l1 l2 = let compare_constants c1 c2 = match c1, c2 with - | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2 + | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 (* Same labels -> same constants. Different labels -> different constants, even if the contents match, because of string constants that must not be diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index d06e4c6fc..0b627537b 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -60,14 +60,14 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst _ -> false - | Udirect_apply(lbl, args, _) -> List.exists occurs args + | Udirect_apply(_lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args - | Uclosure(fundecls, clos) -> List.exists occurs clos - | Uoffset(u, ofs) -> occurs u - | Ulet(id, def, body) -> occurs def || occurs body + | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uoffset(u, _ofs) -> occurs u + | Ulet(_id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> - List.exists (fun (id, u) -> occurs u) decls || occurs body - | Uprim(p, args, _) -> List.exists occurs args + List.exists (fun (_id, u) -> occurs u) decls || occurs body + | Uprim(_p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks @@ -77,12 +77,12 @@ let occurs_var var u = (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr - | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr | Uifthenelse(cond, ifso, ifnot) -> occurs cond || occurs ifso || occurs ifnot | Usequence(u1, u2) -> occurs u1 || occurs u2 | Uwhile(cond, body) -> occurs cond || occurs body - | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body + | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args @@ -103,11 +103,11 @@ let occurs_var var u = let prim_size prim args = match prim with Pidentity -> 0 - | Pgetglobal id -> 1 - | Psetglobal id -> 1 - | Pmakeblock(tag, mut) -> 5 + List.length args - | Pfield f -> 1 - | Psetfield(f, isptr, init) -> + | Pgetglobal _ -> 1 + | Psetglobal _ -> 1 + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield(_f, isptr, init) -> begin match init with | Initialization -> 1 (* never causes a write barrier hit *) | Assignment -> @@ -115,8 +115,8 @@ let prim_size prim args = | Pointer -> 4 | Immediate -> 1 end - | Pfloatfield f -> 1 - | Psetfloatfield (f, _) -> 1 + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args | Praise _ -> 4 @@ -140,19 +140,19 @@ let lambda_smaller lam threshold = let rec lambda_size lam = if !size > threshold then raise Exit; match lam with - Uvar v -> () + Uvar _ -> () | Uconst _ -> incr size - | Udirect_apply(fn, args, _) -> + | Udirect_apply(_, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args - | Uclosure(defs, vars) -> + | Uclosure _ -> raise Exit (* inlining would duplicate function definitions *) - | Uoffset(lam, ofs) -> + | Uoffset(lam, _ofs) -> incr size; lambda_size lam - | Ulet(id, lam, body) -> + | Ulet(_id, lam, body) -> lambda_size lam; lambda_size body - | Uletrec(bindings, body) -> + | Uletrec _ -> raise Exit (* usually too large *) | Uprim(prim, args, _) -> size := !size + prim_size prim args; @@ -175,7 +175,7 @@ let lambda_smaller lam threshold = | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler - | Utrywith(body, id, handler) -> + | Utrywith(body, _id, handler) -> size := !size + 8; lambda_size body; lambda_size handler | Uifthenelse(cond, ifso, ifnot) -> size := !size + 2; @@ -184,9 +184,9 @@ let lambda_smaller lam threshold = lambda_size lam1; lambda_size lam2 | Uwhile(cond, body) -> size := !size + 2; lambda_size cond; lambda_size body - | Ufor(id, low, high, dir, body) -> + | Ufor(_id, low, high, _dir, body) -> size := !size + 4; lambda_size low; lambda_size high; lambda_size body - | Uassign(id, lam) -> + | Uassign(_id, lam) -> incr size; lambda_size lam | Usend(_, met, obj, args, _) -> size := !size + 8; @@ -203,12 +203,12 @@ let lambda_smaller lam threshold = that is without side-effects *and* not containing function definitions *) let rec is_pure_clambda = function - Uvar v -> true + Uvar _ -> true | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false - | Uprim(p, args, _) -> List.for_all is_pure_clambda args + | Uprim(_, args, _) -> List.for_all is_pure_clambda args | _ -> false (* Simplify primitive operations on known arguments *) @@ -542,7 +542,7 @@ let rec substitute fpc sb ulam = bindings1 sb in Uletrec( List.map - (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + (fun (_id, id', rhs) -> (id', substitute fpc sb' rhs)) bindings1, substitute fpc sb' body) | Uprim(p, args, dbg) -> @@ -669,13 +669,13 @@ let bind_params fpc params args body = that is without side-effects *and* not containing function definitions *) let rec is_pure = function - Lvar v -> true - | Lconst cst -> true + Lvar _ -> true + | Lconst _ -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false - | Lprim(p, args) -> List.for_all is_pure args - | Levent(lam, ev) -> is_pure lam + | Lprim(_, args) -> List.for_all is_pure args + | Levent(lam, _ev) -> is_pure lam | _ -> false let warning_if_forced_inline ~loc ~attribute warning = @@ -752,19 +752,19 @@ let rec add_debug_info ev u = match ev.lev_kind with | Lev_after _ -> begin match u with - | Udirect_apply(lbl, args, dinfo) -> + | Udirect_apply(lbl, args, _dinfo) -> Udirect_apply(lbl, args, Debuginfo.from_call ev) - | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), - args2, dinfo2) -> + | Ugeneric_apply(Udirect_apply(lbl, args1, _dinfo1), + args2, _dinfo2) -> Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), args2, Debuginfo.from_call ev) - | Ugeneric_apply(fn, args, dinfo) -> + | Ugeneric_apply(fn, args, _dinfo) -> Ugeneric_apply(fn, args, Debuginfo.from_call ev) - | Uprim(Praise k, args, dinfo) -> + | Uprim(Praise k, args, _dinfo) -> Uprim(Praise k, args, Debuginfo.from_call ev) - | Uprim(p, args, dinfo) -> + | Uprim(p, args, _dinfo) -> Uprim(p, args, Debuginfo.from_call ev) - | Usend(kind, u1, u2, args, dinfo) -> + | Usend(kind, u1, u2, args, _dinfo) -> Usend(kind, u1, u2, args, Debuginfo.from_call ev) | Usequence(u1, u2) -> Usequence(u1, add_debug_info ev u2) @@ -790,7 +790,7 @@ let close_approx_var fenv cenv id = (subst, approx) let close_var fenv cenv id = - let (ulam, app) = close_approx_var fenv cenv id in ulam + let (ulam, _app) = close_approx_var fenv cenv id in ulam let rec close fenv cenv = function Lvar id -> @@ -823,7 +823,7 @@ let rec close fenv cenv = function | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) in make_const (transl cst) - | Lfunction{kind; params; body} as funct -> + | Lfunction _ as funct -> close_one_function fenv cenv (Ident.create "fun") funct (* We convert [f a] to [let a' = a in fun b c -> f a' b c] @@ -842,7 +842,7 @@ let rec close fenv cenv = function let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((_ufunct, Value_closure(fundesc, _approx_res)), uargs) when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> (Ident.create "arg", arg) ) uargs in @@ -857,7 +857,7 @@ let rec close fenv cenv = function (Ulet ( arg1, arg2, body)) in let internal_args = - (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) @ (List.map (fun arg -> Lvar arg ) final_args) in let (new_fun, approx) = close fenv cenv @@ -876,7 +876,7 @@ let rec close fenv cenv = function warning_if_forced_inline ~loc ~attribute "Partial application"; (new_fun, approx) - | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in warning_if_forced_inline ~loc ~attribute "Over-application"; @@ -907,7 +907,7 @@ let rec close fenv cenv = function end | Lletrec(defs, body) -> if List.for_all - (function (id, Lfunction _) -> true | _ -> false) + (function (_id, Lfunction _) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) @@ -915,12 +915,12 @@ let rec close fenv cenv = function let clos_ident = Ident.create "clos" in let fenv_body = List.fold_right - (fun (id, pos, approx) fenv -> Tbl.add id approx fenv) + (fun (id, _pos, approx) fenv -> Tbl.add id approx fenv) infos fenv in let (ubody, approx) = close fenv_body cenv body in let sb = List.fold_right - (fun (id, pos, approx) sb -> + (fun (id, pos, _approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), @@ -960,7 +960,7 @@ let rec close fenv cenv = function (Uprim(Psetfield(n, is_ptr, init), [getglobal id; ulam], Debuginfo.none), Value_unknown) | Lprim(Praise k, [Levent(arg, ev)]) -> - let (ulam, approx) = close fenv cenv arg in + let (ulam, _approx) = close fenv cenv arg in (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> @@ -970,9 +970,9 @@ let rec close fenv cenv = function let fn fail = let (uarg, _) = close fenv cenv arg in let const_index, const_actions, fconst = - close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail and block_index, block_actions, fblock = - close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in let ulam = Uswitch (uarg, @@ -1066,7 +1066,7 @@ and close_list_approx fenv cenv = function (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function - Lfunction{kind; params; body} as funct -> + Lfunction _ as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam @@ -1085,7 +1085,7 @@ and close_functions fenv cenv fun_defs = fun_defs) in let inline_attribute = match fun_defs with - | [_, Lfunction{kind; params; body; attr = { inline }}] -> inline + | [_, Lfunction{attr = { inline }}] -> inline | _ -> Default_inline (* recursive functions can't be inlined *) in @@ -1117,14 +1117,14 @@ and close_functions fenv cenv fun_defs = (* Build an approximate fenv for compiling the functions *) let fenv_rec = List.fold_right - (fun (id, params, body, fundesc) fenv -> + (fun (id, _params, _body, fundesc) fenv -> Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv) uncurried_defs fenv in (* Determine the offsets of each function's closure in the shared block *) let env_pos = ref (-1) in let clos_offsets = List.map - (fun (id, params, body, fundesc) -> + (fun (_id, _params, _body, fundesc) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); pos) @@ -1143,7 +1143,7 @@ and close_functions fenv cenv fun_defs = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, body, fundesc) pos env -> + (fun (id, _params, _body, _fundesc) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in @@ -1193,7 +1193,7 @@ and close_functions fenv cenv fun_defs = recompile *) Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> + (fun (_id, _params, _body, fundesc) -> fundesc.fun_closed <- false; fundesc.fun_inline <- None; ) @@ -1221,7 +1221,7 @@ and close_one_function fenv cenv id funct = (* Close a switch *) -and close_switch arg fenv cenv cases num_keys default = +and close_switch fenv cenv cases num_keys default = let ncases = List.length cases in let index = Array.make num_keys 0 and store = Storer.mk_store () in @@ -1287,7 +1287,7 @@ let collect_exported_structured_constants a = | Uconst_ref (s, (Some c)) -> Compilenv.add_exported_constant s; structured_constant c - | Uconst_ref (s, None) -> assert false (* Cannot be generated *) + | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) | Uconst_int _ | Uconst_ptr _ -> () and structured_constant = function | Uconst_block (_, ul) -> List.iter const ul @@ -1339,7 +1339,7 @@ let intro size lam = let id = Compilenv.make_symbol None in global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); - let (ulam, approx) = close Tbl.empty Tbl.empty lam in + let (ulam, _approx) = close Tbl.empty Tbl.empty lam in let opaque = !Clflags.opaque || Env.is_imported_opaque (Compilenv.current_unit_name ()) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 1e3628f88..32a98bdb5 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -156,7 +156,7 @@ and mult_power2 c n = lsl_int c (Cconst_int (Misc.log2 n)) let rec mul_int c1 c2 = match (c1, c2) with - | (c, Cconst_int 0) | (Cconst_int 0, c) -> + | (_, Cconst_int 0) | (Cconst_int 0, _) -> Cconst_int 0 | (c, Cconst_int 1) | (Cconst_int 1, c) -> c @@ -431,7 +431,7 @@ let safe_div_bi = safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) let safe_mod_bi = - safe_divmod_bi mod_int (fun c1 -> Cconst_int 0) + safe_divmod_bi mod_int (fun _ -> Cconst_int 0) (* Bool *) @@ -444,7 +444,7 @@ let test_bool = function let box_float c = Cop(Calloc, [alloc_float_header; c]) let rec unbox_float = function - Cop(Calloc, [header; c]) -> c + Cop(Calloc, [_header; c]) -> c | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) | Cifthenelse(cond, e1, e2) -> Cifthenelse(cond, unbox_float e1, unbox_float e2) @@ -482,9 +482,9 @@ let rec remove_unit = function Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) - | Cop(Capply (mty, dbg), args) -> + | Cop(Capply (_mty, dbg), args) -> Cop(Capply (typ_void, dbg), args) - | Cop(Cextcall(proc, mty, alloc, dbg), args) -> + | Cop(Cextcall(proc, _mty, alloc, dbg), args) -> Cop(Cextcall(proc, typ_void, alloc, dbg), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c @@ -692,9 +692,9 @@ let rec expr_size env = function RHS_block (fundecls_size fundecls + List.length clos_vars) | Ulet(id, exp, body) -> expr_size (Ident.add id (expr_size env exp) env) body - | Uletrec(bindings, body) -> + | Uletrec(_bindings, body) -> expr_size env body - | Uprim(Pmakeblock(tag, mut), args, _) -> + | Uprim(Pmakeblock _, args, _) -> RHS_block (List.length args) | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) -> RHS_block (List.length args) @@ -710,7 +710,7 @@ let rec expr_size env = function when prim_name = "caml_check_value_is_closure" -> (* Used for "-clambda-checks". *) expr_size env closure - | Usequence(exp, exp') -> + | Usequence(_exp, exp') -> expr_size env exp' | _ -> RHS_nonrec @@ -813,15 +813,15 @@ let split_int64_for_32bit_target arg = let rec unbox_int bi arg = match arg with - Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) + Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32])]) when bi = Pint32 && size_int = 8 && big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) + | Cop(Calloc, [_hdr; _ops; contents]) when bi = Pint32 && size_int = 8 && not big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) - | Cop(Calloc, [hdr; ops; contents]) -> + | Cop(Calloc, [_hdr; _ops; contents]) -> contents | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) | Cifthenelse(cond, e1, e2) -> @@ -1182,9 +1182,9 @@ let simplif_primitive_32bits = function | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64") | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64") @@ -1197,13 +1197,13 @@ let simplif_primitive p = match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> + | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p @@ -1371,7 +1371,7 @@ let rec is_unboxed_number env e = | Parrayrefu Pfloatarray -> Boxed Boxed_float | Parrayrefs Pfloatarray -> Boxed Boxed_float | Pbintofint bi -> Boxed (Boxed_integer bi) - | Pcvtbint(src, dst) -> Boxed (Boxed_integer dst) + | Pcvtbint(_src, dst) -> Boxed (Boxed_integer dst) | Pnegbint bi -> Boxed (Boxed_integer bi) | Paddbint bi -> Boxed (Boxed_integer bi) | Psubbint bi -> Boxed (Boxed_integer bi) @@ -1512,9 +1512,9 @@ let rec transl env e = begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) - | (Pmakeblock(tag, mut), []) -> + | (Pmakeblock _, []) -> assert false - | (Pmakeblock(tag, mut), args) -> + | (Pmakeblock(tag, _mut), args) -> make_alloc tag (List.map (transl env) args) | (Pccall prim, args) -> transl_ccall env prim args dbg @@ -1536,10 +1536,10 @@ let rec transl env e = Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true in transl_ccall env prim_obj_dup [arg] dbg - | (Pmakearray (kind, _), []) -> + | (Pmakearray _, []) -> transl_structured_constant (Uconst_block(0, [])) | (Pmakearray (kind, _), args) -> transl_make_array env kind args - | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get unsafe elt_kind layout (transl env arg1) (List.map (transl env) argl) dbg in @@ -1552,7 +1552,7 @@ let rec transl env e = | Pbigarray_caml_int -> force_tag_int elt | _ -> tag_int elt end - | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in return_unit(bigarray_set unsafe elt_kind layout (transl env arg1) @@ -2411,15 +2411,15 @@ and transl_letrec env bindings cont = Cop(Cextcall(prim, typ_val, true, Debuginfo.none), [int_const sz]) in let rec init_blocks = function | [] -> fill_nonrec bsz - | (id, exp, RHS_block sz) :: rem -> + | (id, _exp, RHS_block sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) - | (id, exp, RHS_floatblock sz) :: rem -> + | (id, _exp, RHS_floatblock sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem -> fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet(id, transl env exp, fill_nonrec rem) @@ -2430,7 +2430,7 @@ and transl_letrec env bindings cont = Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), [Cvar id; transl env exp]) in Csequence(op, fill_blocks rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 094cdb890..d37d87ce3 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -26,7 +26,7 @@ type allocation_state = let allocated_size = function No_alloc -> 0 - | Pending_alloc(reg, ofs) -> ofs + | Pending_alloc(_, ofs) -> ofs let rec combine i allocstate = match i.desc with @@ -55,7 +55,7 @@ let rec combine i allocstate = let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, allocated_size allocstate) - | Iop op -> + | Iop _ -> let (newnext, sz) = combine i.next allocstate in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml index 4570d8efc..b86ee9669 100644 --- a/asmcomp/deadcode.ml +++ b/asmcomp/deadcode.ml @@ -57,7 +57,7 @@ let rec deadcode i = let (handler', _) = deadcode handler in let (s, _) = deadcode i.next in ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) - | Iexit nfail -> + | Iexit _ -> (i, i.live) | Itrywith(body, handler) -> let (body', _) = deadcode body in diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml index 85c7223f6..9011d8f82 100644 --- a/asmcomp/i386/CSE.ml +++ b/asmcomp/i386/CSE.ml @@ -20,7 +20,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index b17188afc..3e0cc5af8 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -79,11 +79,11 @@ let offset_addressing addr delta = | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 - | Iindexed2 n -> 2 - | Iscaled(scale, n) -> 1 - | Iindexed2scaled(scale, n) -> 2 + Ibased _ -> 0 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 + | Iscaled _ -> 1 + | Iindexed2scaled _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index b7e17843a..8036de7c5 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -140,7 +140,7 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" (* Six arguments in integer registers plus eight in global memory. *) let max_arguments_for_tailcalls = 14 @@ -148,16 +148,16 @@ let max_arguments_for_tailcalls = 14 let loc_arguments arg = calling_conventions 0 5 100 99 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc + let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc -let loc_external_arguments arg = + let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc +let loc_external_arguments _arg = fatal_error "Proc.loc_external_arguments" let loc_external_results res = match res with | [|{typ=Int};{typ=Int}|] -> [|eax; edx|] | _ -> - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc let loc_exn_bucket = eax @@ -195,7 +195,7 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) -let safe_register_pressure op = 4 +let safe_register_pressure _op = 4 let max_register_pressure = function Iextcall(_, _) -> [| 4; max_int |] diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 67f3e5712..63034d7a4 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -71,7 +71,7 @@ method! reload_operation op arg res = method! reload_test tst arg = match tst with - Iinttest cmp -> + Iinttest _ -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index f37781d2a..b70b05fe7 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -88,7 +88,7 @@ let rec float_needs = function let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, ty_res, alloc, dbg), args) + | Cop(Cextcall(fn, _ty_res, _alloc, _dbg), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -138,7 +138,7 @@ let pseudoregs_for_operation op arg res = (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr, _) -> + | Istore((Byte_unsigned | Byte_signed), _, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -157,18 +157,18 @@ class selector = object (self) inherit Selectgen.selector_generic as super -method is_immediate (n : int) = true +method is_immediate (_n : int) = true method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, alloc, _), args) + | Cop(Cextcall(fn, _, _, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e -method select_addressing chunk exp = +method select_addressing _chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) @@ -201,7 +201,7 @@ method! select_operation op args = (* Recognize the LEA instruction *) Caddi | Caddv | Cadda | Csubi -> begin match self#select_addressing Word_int (Cop(op, args)) with - (Iindexed d, _) -> super#select_operation op args + (Iindexed _, _) | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end @@ -228,7 +228,7 @@ method! select_operation op args = super#select_operation op args end (* Recognize inlined floating point operations *) - | Cextcall(fn, ty_res, false, dbg) + | Cextcall(fn, _ty_res, false, _dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* i386 does not support immediate operands for multiply high signed *) diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 2376aa219..637229efb 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -91,16 +91,16 @@ let build_graph fundecl = add_interf_move i.arg.(0) i.res.(0) i.live; interf i.next | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_imm _) -> () + | Iop _ -> add_interf_set i.res i.live; add_interf_self i.res; interf i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> interf ifso; interf ifnot; interf i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do interf cases.(i) done; @@ -163,14 +163,14 @@ let build_graph fundecl = add_pref (weight / 4) i.res.(0) i.arg.(0); prefer weight i.next | Iop(Itailcall_ind) -> () - | Iop(Itailcall_imm lbl) -> () - | Iop op -> + | Iop(Itailcall_imm _) -> () + | Iop _ -> prefer weight i.next - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> prefer (weight / 2) ifso; prefer (weight / 2) ifnot; prefer weight i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do prefer (weight / 2) cases.(i) done; diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 1ce943ab5..5986cce1a 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -68,12 +68,12 @@ let rec live i finally = i.live <- across; Reg.add_set_array across i.arg end - | Iifthenelse(test, ifso, ifnot) -> + | Iifthenelse(_test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in i.live <- at_fork; Reg.add_set_array at_fork i.arg - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> let at_join = live i.next finally in let at_fork = ref Reg.Set.empty in for i = 0 to Array.length cases - 1 do diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 0770b988b..736779c29 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -115,9 +115,9 @@ let rec instr_iter f i = match i.desc with Iend -> () | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () - | Iifthenelse(tst, ifso, ifnot) -> + | Iifthenelse(_tst, ifso, ifnot) -> instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next - | Iswitch(index, cases) -> + | Iswitch(_index, cases) -> for i = 0 to Array.length cases - 1 do instr_iter f cases.(i) done; diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml index 3106bdd80..23028c907 100644 --- a/asmcomp/power/CSE.ml +++ b/asmcomp/power/CSE.ml @@ -19,7 +19,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 2e7d19caf..30bbd4f54 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -85,8 +85,8 @@ let offset_addressing addr delta = | Iindexed2 -> assert false let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 | Iindexed2 -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index c9b26e85c..08077a632 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -116,7 +116,6 @@ let datag = if ppc64 then ".quad" else ".long" let mullg = if ppc64 then "mulld" else "mullw" let divg = if ppc64 then "divd" else "divw" let tglle = if ppc64 then "tdlle" else "twlle" -let slgi = if ppc64 then "sldi" else "slwi" (* Output a processor register *) @@ -422,17 +421,17 @@ module BR = Branch_relaxation.Make (struct let size = match abi with - | ELF32 -> (fun a b c -> a) - | ELF64v1 -> (fun a b c -> b) - | ELF64v2 -> (fun a b c -> c) + | ELF32 -> (fun a _ _ -> a) + | ELF64v1 -> (fun _ b _ -> b) + | ELF64v2 -> (fun _ _ c -> c) let tocload_size() = if !big_toc || !Clflags.for_package <> None then 2 else 1 let load_store_size = function - | Ibased(s, d) -> + | Ibased(_s, d) -> if abi = ELF32 then 2 else begin - let (lo, hi) = low_high_s d in + let (_lo, hi) = low_high_s d in tocload_size() + (if hi = 0 then 1 else 2) end | Iindexed ofs -> if is_immediate ofs then 1 else 3 @@ -443,50 +442,50 @@ module BR = Branch_relaxation.Make (struct | Lop(Imove | Ispill | Ireload) -> 1 | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then 1 - else if (let (lo, hi) = native_low_high_s n in + else if (let (_lo, hi) = native_low_high_s n in hi >= -0x8000 && hi <= 0x7FFF) then 2 - else if (let (lo, hi) = native_low_high_u n in + else if (let (_lo, hi) = native_low_high_u n in hi >= -0x8000 && hi <= 0x7FFF) then 2 else tocload_size() - | Lop(Iconst_float s) -> if abi = ELF32 then 2 else tocload_size() - | Lop(Iconst_symbol s) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size() + | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size() | Lop(Icall_ind) -> size 2 5 4 - | Lop(Icall_imm s) -> size 1 3 3 + | Lop(Icall_imm _) -> size 1 3 3 | Lop(Itailcall_ind) -> size 5 7 6 | Lop(Itailcall_imm s) -> if s = !function_name then 1 else size 4 (7 + tocload_size()) (6 + tocload_size()) - | Lop(Iextcall(s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size()) - | Lop(Iextcall(s, false)) -> size 1 2 2 - | Lop(Istackoffset n) -> 1 + | Lop(Iextcall(_s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size()) + | Lop(Iextcall(_s, false)) -> size 1 2 2 + | Lop(Istackoffset _) -> 1 | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr, _)) -> load_store_size addr - | Lop(Ialloc n) -> 4 - | Lop(Ispecific(Ialloc_far n)) -> 5 + | Lop(Istore(_chunk, addr, _)) -> load_store_size addr + | Lop(Ialloc _) -> 4 + | Lop(Ispecific(Ialloc_far _)) -> 5 | Lop(Iintop Imod) -> 3 - | Lop(Iintop(Icomp cmp)) -> 4 - | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Icomp cmp, n)) -> 4 - | Lop(Iintop_imm(op, n)) -> 1 + | Lop(Iintop(Icomp _)) -> 4 + | Lop(Iintop _) -> 1 + | Lop(Iintop_imm(Icomp _, _)) -> 4 + | Lop(Iintop_imm _) -> 1 | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 | Lop(Ifloatofint) -> 9 | Lop(Iintoffloat) -> 4 - | Lop(Ispecific sop) -> 1 + | Lop(Ispecific _) -> 1 | Lreloadretaddr -> 2 | Lreturn -> 2 - | Llabel lbl -> 0 - | Lbranch lbl -> 1 - | Lcondbranch(tst, lbl) -> 2 + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch _ -> 2 | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) - | Lswitch jumptbl -> size 7 (5 + tocload_size()) (5 + tocload_size()) - | Lsetuptrap lbl -> size 1 2 2 + | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size()) + | Lsetuptrap _ -> size 1 2 2 | Lpushtrap -> size 4 5 5 | Lpoptrap -> 2 | Lraise _ -> 6 @@ -510,17 +509,17 @@ let emit_instr i = let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` mr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ` fmr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` stfd {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` lfd {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index caa8cf74d..00bc93f54 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -168,7 +168,7 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let single_regs arg = Array.map (fun arg -> [| arg |]) arg let ensure_single_regs res = @@ -185,12 +185,12 @@ let loc_arguments arg = in (ensure_single_regs loc, ofs) let loc_parameters arg = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 7 100 112 incoming 0 false (single_regs arg) in ensure_single_regs loc let loc_results res = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 7 100 112 not_supported 0 false (single_regs res) in ensure_single_regs loc @@ -244,12 +244,10 @@ let loc_external_arguments = then (loc, ofs) else (loc, 0) -let extcall_use_push = false - (* Results are in GPR 3 and FPR 1 *) let loc_external_results res = - let (loc, ofs) = + let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported 0 false (single_regs res) in ensure_single_regs loc @@ -260,7 +258,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 14f2ed81d..dcbfca79f 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -38,7 +38,7 @@ method oper_latency = function | Ispecific(Imultaddf | Imultsubf) -> 5 | _ -> 1 -method reload_retaddr_latency = 12 +method! reload_retaddr_latency = 12 (* If we can have that many cycles between the reloadretaddr and the return, we can expect that the blr branch will be completely folded. *) @@ -56,7 +56,7 @@ method oper_issue_cycles = function | Iintoffloat -> 4 | _ -> 1 -method reload_retaddr_issue_cycles = 3 +method! reload_retaddr_issue_cycles = 3 (* load then stalling mtlr *) end diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index c7ef00c51..71c474906 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -51,7 +51,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 32767) && (n >= -32768) -method select_addressing chunk exp = +method select_addressing _chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index b97f53705..ee4f52b90 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -54,8 +54,8 @@ let chunk = function | Double_u -> "float64u" let operation = function - | Capply(ty, d) -> "app" ^ Debuginfo.to_string d - | Cextcall(lbl, ty, alloc, d) -> + | Capply(_ty, d) -> "app" ^ Debuginfo.to_string d + | Cextcall(lbl, _ty, _alloc, d) -> Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload c -> Printf.sprintf "load %s" (chunk c) | Calloc -> "alloc" diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 09c68b7e6..0f7e8f8a4 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -73,7 +73,7 @@ method reload_operation op arg res = | _ -> (self#makeregs arg, self#makeregs res) -method reload_test tst args = +method reload_test _tst args = self#makeregs args method private reload i = diff --git a/asmcomp/s390x/CSE.ml b/asmcomp/s390x/CSE.ml index e5805f244..ad085bab0 100644 --- a/asmcomp/s390x/CSE.ml +++ b/asmcomp/s390x/CSE.ml @@ -21,7 +21,7 @@ open Arch open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic as super diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml index 954beb932..a6353fdf9 100644 --- a/asmcomp/s390x/arch.ml +++ b/asmcomp/s390x/arch.ml @@ -65,8 +65,8 @@ let offset_addressing addr delta = | Iindexed2 n -> Iindexed2(n + delta) let num_args_addressing = function - | Iindexed n -> 1 - | Iindexed2 n -> 2 + | Iindexed _ -> 1 + | Iindexed2 _ -> 2 (* Printing operations and addressing modes *) diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index 8226464bf..04379aa56 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -86,10 +86,6 @@ let emit_reg r = | _ -> fatal_error "Emit.emit_reg" -let emit_gpr r = emit_string "%r"; emit_int r - -let emit_fpr r = emit_string "%f"; emit_int r - (* Special registers *) let reg_f15 = phys_reg 115 @@ -292,17 +288,17 @@ let emit_instr i = let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with - {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` lgr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> ` ldr {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} -> ` stg {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` std {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} -> ` lg {emit_reg dst}, {emit_stack src}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` ldy {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index dd1629660..3dee61a41 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -126,16 +126,16 @@ let calling_conventions let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let max_arguments_for_tailcalls = 5 let loc_arguments arg = calling_conventions 0 4 100 103 outgoing 0 arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc + let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc + let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc (* C calling conventions under SVR4: use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions. @@ -150,12 +150,10 @@ let loc_external_arguments arg = calling_conventions 0 4 100 103 outgoing 160 arg in (Array.map (fun reg -> [|reg|]) loc, ofs) -let extcall_use_push = false - (* Results are in GPR 2 and FPR 0 *) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc (* Exceptions are in GPR 2 *) @@ -163,7 +161,7 @@ let loc_exn_bucket = phys_reg 0 (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/s390x/scheduling.ml b/asmcomp/s390x/scheduling.ml index 6ac11d352..a766d6a34 100644 --- a/asmcomp/s390x/scheduling.ml +++ b/asmcomp/s390x/scheduling.ml @@ -44,7 +44,7 @@ method oper_latency = function | Ispecific(Imultaddf | Imultsubf) -> 8 | _ -> 2 -method reload_retaddr_latency = 4 +method! reload_retaddr_latency = 4 (* Issue cycles. Rough approximations. *) @@ -56,7 +56,7 @@ method oper_issue_cycles = function | Iintop_imm(Icomp _, _) -> 4 | _ -> 1 -method reload_retaddr_issue_cycles = 1 +method! reload_retaddr_issue_cycles = 1 end diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml index 4c0df5f03..7ef66a1d5 100644 --- a/asmcomp/s390x/selection.ml +++ b/asmcomp/s390x/selection.ml @@ -51,7 +51,7 @@ let pseudoregs_for_operation op arg res = (* Two-address binary operations: arg.(0) and res.(0) must be the same *) | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> ([|res.(0); arg.(1)|], res) - | Ispecific(sop) -> + | Ispecific _ -> ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |]) (* One-address unary operations: arg.(0) and res.(0) must be the same *) | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res) @@ -64,7 +64,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 2147483647) && (n >= -2147483648) -method select_addressing chunk exp = +method select_addressing _chunk exp = let (a, d) = select_addr exp in (* 20-bit signed displacement *) if d < 0x80000 && d >= -0x80000 then begin diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index ce672a6bf..c18ad0fad 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -27,7 +27,7 @@ type environment = (Ident.t, Reg.t array) Tbl.t let oper_result_type = function Capply(ty, _) -> ty - | Cextcall(s, ty, alloc, _) -> ty + | Cextcall(_s, ty, _alloc, _) -> ty | Cload c -> begin match c with | Word_val -> typ_val @@ -35,7 +35,7 @@ let oper_result_type = function | _ -> typ_int end | Calloc -> typ_val - | Cstore (c, _) -> typ_void + | Cstore _ -> typ_void | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int @@ -69,11 +69,11 @@ let size_expr env exp = end | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 - | Cop(op, args) -> + | Cop(op, _) -> size_machtype(oper_result_type op) | Clet(id, arg, body) -> size (Tbl.add id (size localenv arg) localenv) body - | Csequence(e1, e2) -> + | Csequence(_e1, e2) -> size localenv e2 | _ -> fatal_error "Selection.size_expr" @@ -136,7 +136,7 @@ let join opt_r1 seq1 opt_r2 seq2 = let join_array rs = let some_res = ref None in for i = 0 to Array.length rs - 1 do - let (r, s) = rs.(i) in + let (r, _) = rs.(i) in if r <> None then some_res := r done; match !some_res with @@ -190,7 +190,7 @@ method is_simple_expr = function | Cconst_natpointer _ -> true | Cvar _ -> true | Ctuple el -> List.for_all self#is_simple_expr el - | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body + | Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 | Cop(op, args) -> begin match op with @@ -251,9 +251,9 @@ method mark_instr = function method select_operation op args = match (op, args) with - (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply(ty, dbg), _) -> (Icall_ind, args) - | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) + (Capply _, Cconst_symbol s :: rem) -> (Icall_imm s, rem) + | (Capply _, _) -> (Icall_ind, args) + | (Cextcall(s, _ty, alloc, _dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) @@ -505,7 +505,7 @@ method emit_expr env exp = self#insert_debug (Iraise k) dbg rd [||]; None end - | Cop(Ccmpf comp, args) -> + | Cop(Ccmpf _, _) -> self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) | Cop(op, args) -> begin match self#emit_parts_list env args with @@ -556,7 +556,7 @@ method emit_expr env exp = | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#emit_expr env e2 + | Some _ -> self#emit_expr env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -577,12 +577,12 @@ method emit_expr env exp = let rscases = Array.map (self#emit_sequence env) ecases in let r = join_array rscases in self#insert (Iswitch(index, - Array.map (fun (r, s) -> s#extract) rscases)) + Array.map (fun (_, s) -> s#extract) rscases)) rsel [||]; r end | Cloop(ebody) -> - let (rarg, sbody) = self#emit_sequence env ebody in + let (_rarg, sbody) = self#emit_sequence env ebody in self#insert (Iloop(sbody#extract)) [||] [||]; Some [||] | Ccatch(nfail, ids, e1, e2) -> @@ -796,7 +796,7 @@ method emit_tail env exp = | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> () - | Some r1 -> self#emit_tail env e2 + | Some _ -> self#emit_tail env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in @@ -868,7 +868,7 @@ method emit_fundecl f = let loc_arg = Proc.loc_parameters rarg in let env = List.fold_right2 - (fun (id, ty) r env -> Tbl.add id r env) + (fun (id, _ty) r env -> Tbl.add id r env) f.Cmm.fun_args rargs Tbl.empty in self#insert_moves loc_arg rarg; self#emit_tail env f.Cmm.fun_body; @@ -890,7 +890,7 @@ end let is_tail_call nargs = assert (Reg.dummy.typ = Int); let args = Array.make (nargs + 1) Reg.dummy in - let (loc_arg, stack_ofs) = Proc.loc_arguments args in + let (_loc_arg, stack_ofs) = Proc.loc_arguments args in stack_ofs = 0 let _ = diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml index 6c4cf458d..d73dd00df 100644 --- a/asmcomp/sparc/CSE.ml +++ b/asmcomp/sparc/CSE.ml @@ -18,7 +18,7 @@ open Mach open CSEgen -class cse = object (self) +class cse = object inherit cse_generic (* as super *) diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index f7e388be7..d9cf94e7b 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -63,8 +63,8 @@ let offset_addressing addr delta = | Iindexed n -> Iindexed(n + delta) let num_args_addressing = function - Ibased(s, n) -> 0 - | Iindexed n -> 1 + Ibased _ -> 0 + | Iindexed _ -> 1 (* Printing operations and addressing modes *) @@ -77,5 +77,5 @@ let print_addressing printreg addr ppf arg = let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx -let print_specific_operation printreg op ppf arg = +let print_specific_operation _printreg _op _ppf _arg = Misc.fatal_error "Arch_sparc.print_specific_operation" diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 74d61be20..63da27a90 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -278,16 +278,16 @@ let rec emit_instr i dslot = | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in begin match (src, dst) with - {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Reg rd} -> + {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` mov {emit_reg src}, {emit_reg dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} -> if !arch_version = SPARC_V9 then ` fmovd {emit_reg src}, {emit_reg dst}\n` else begin ` fmovs {emit_reg src}, {emit_reg dst}\n`; ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` end - | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr | Val)} -> + | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} -> (* This happens when calling C functions and passing a float arg in %o0...%o5 *) ` sub %sp, 8, %sp\n`; @@ -304,13 +304,13 @@ let rec emit_instr i dslot = fatal_error "Emit: Imove Float [| _; _ |]" end; ` add %sp, 8, %sp\n` - | {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Stack sd} -> + | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} -> ` st {emit_reg src}, {emit_stack dst}\n` - | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + | {loc = Reg _; typ = Float}, {loc = Stack _} -> ` std {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack ss; typ = (Int | Addr | Val)}, {loc = Reg rd} -> + | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} -> ` ld {emit_stack src}, {emit_reg dst}\n` - | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + | {loc = Stack _; typ = Float}, {loc = Reg _} -> ` ldd {emit_stack src}, {emit_reg dst}\n` | (_, _) -> fatal_error "Emit: Imove" @@ -514,7 +514,7 @@ let rec emit_instr i dslot = ` st %f30, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; ` add %sp, 8, %sp\n` - | Lop(Ispecific sop) -> + | Lop(Ispecific _) -> assert false | Lreloadretaddr -> let n = frame_size() in diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 3f5464a94..d3b131e9d 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -134,16 +134,16 @@ let calling_conventions first_int last_int first_float last_float make_stack let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs -let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +let not_supported _ofs = fatal_error "Proc.loc_results: cannot call" let max_arguments_for_tailcalls = 10 let loc_arguments arg = calling_conventions 6 15 100 105 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc + let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc (* On the Sparc, all arguments to C functions, even floating-point arguments, are passed in %o0..%o5, then on the stack *) @@ -188,13 +188,13 @@ let loc_external_arguments arg = (loc, Misc.align (!ofs + 4) 8) let loc_external_results res = - let (loc, ofs) = calling_conventions 0 1 100 100 not_supported res in loc + let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* $o0 *) (* Volatile registers: none *) -let regs_are_volatile rs = false +let regs_are_volatile _rs = false (* Registers destroyed by operations *) diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 288c0cb62..986a2fba5 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 4095) && (n >= -4096) -method select_addressing chunk = function +method select_addressing _chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n]) -> diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 7c755fce2..a90a67422 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -72,7 +72,7 @@ let add_superpressure_regs op live_regs res_regs spilled = (fun r -> if Reg.Set.mem r spilled then () else begin match r.loc with - Stack s -> () + Stack _ -> () | _ -> let c = Proc.register_class r in pressure.(c) <- pressure.(c) + 1 end) diff --git a/asmcomp/split.ml b/asmcomp/split.ml index bac047e9b..b64f70431 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -87,8 +87,8 @@ let identify_sub sub1 sub2 reg = let merge_substs sub1 sub2 i = match (sub1, sub2) with (None, None) -> None - | (Some s1, None) -> sub1 - | (None, Some s2) -> sub2 + | (Some _, None) -> sub1 + | (None, Some _) -> sub2 | (Some s1, Some s2) -> Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg); sub1 @@ -155,9 +155,9 @@ let rec rename i sub = | Iswitch(index, cases) -> let new_sub_cases = Array.map (fun c -> rename c sub) cases in let sub_merge = - merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in + merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in let (new_next, sub_next) = rename i.next sub_merge in - (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases)) + (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases)) (subst_regs i.arg sub) [||] new_next, sub_next) | Iloop(body) -> @@ -206,7 +206,7 @@ let fundecl f = reset (); let new_args = Array.copy f.fun_args in - let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in + let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; set_repres new_body; equiv_classes := Reg.Map.empty; diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 7af65f648..720bd645a 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -368,7 +368,7 @@ module Make(I:I) = struct (* Module entry point *) let catch arg k = match arg with - | Cexit (e,[]) -> k arg + | Cexit (_e,[]) -> k arg | _ -> let e = next_raise_count () in Ccatch (e,[],k (Cexit (e,[])),arg) diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 51e456e84..f15cf0320 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -143,7 +143,7 @@ let rec check_recordwith_updates id e = ;; let rec size_of_lambda = function - | Lfunction{kind; params; body} as funct -> + | Lfunction{params} as funct -> RHS_function (1 + IdentSet.cardinal(free_variables funct), List.length params) | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) @@ -153,21 +153,21 @@ let rec size_of_lambda = function | Record_float -> RHS_floatblock size | Record_extension -> RHS_block (size + 1) end - | Llet(str, id, arg, body) -> size_of_lambda body - | Lletrec(bindings, body) -> size_of_lambda body - | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) + | Llet(_str, _id, _arg, body) -> size_of_lambda body + | Lletrec(_bindings, body) -> size_of_lambda body + | Lprim(Pmakeblock _, args) -> RHS_block (List.length args) | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) -> RHS_block (List.length args) | Lprim (Pmakearray (Pfloatarray, _), args) -> RHS_floatblock (List.length args) - | Lprim (Pmakearray (Pgenarray, _), args) -> assert false - | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> + | Lprim (Pmakearray (Pgenarray, _), _) -> assert false + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _) -> RHS_block size - | Lprim (Pduprecord (Record_extension, size), args) -> + | Lprim (Pduprecord (Record_extension, size), _) -> RHS_block (size + 1) - | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size + | Lprim (Pduprecord (Record_float, size), _) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam - | Lsequence (lam, lam') -> size_of_lambda lam' + | Lsequence (_lam, lam') -> size_of_lambda lam' | _ -> RHS_nonrec (**** Merging consecutive events ****) @@ -310,9 +310,9 @@ let comp_primitive p args = Pgetglobal id -> Kgetglobal id | Psetglobal id -> Ksetglobal id | Pintcomp cmp -> Kintcomp cmp - | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag) + | Pmakeblock(tag, _mut) -> Kmakeblock(List.length args, tag) | Pfield n -> Kgetfield n - | Psetfield(n, ptr, _init) -> Ksetfield n + | Psetfield(n, _ptr, _init) -> Ksetfield n | Pfloatfield n -> Kgetfloatfield n | Psetfloatfield (n, _init) -> Ksetfloatfield n | Pduprecord _ -> Kccall("caml_obj_dup", 1) @@ -356,7 +356,7 @@ let comp_primitive p args = | Pstring_set_16(_) -> Kccall("caml_string_set16", 3) | Pstring_set_32(_) -> Kccall("caml_string_set32", 3) | Pstring_set_64(_) -> Kccall("caml_string_set64", 3) - | Parraylength kind -> Kvectlength + | Parraylength _ -> Kvectlength | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2) | Parrayrefs _ -> Kccall("caml_array_get_addr", 2) @@ -402,12 +402,12 @@ let comp_primitive p args = | Plslbint bi -> comp_bint_primitive bi "shift_left" args | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args | Pasrbint bi -> comp_bint_primitive bi "shift_right" args - | Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2) - | Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2) - | Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2) - | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) - | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) - | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) + | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2) + | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2) + | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2) + | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2) + | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2) + | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1) @@ -497,7 +497,7 @@ let rec comp_expr env exp sz cont = comp_args env args' (sz + 3) (getmethod :: Kapply nargs :: cont1) end - | Lfunction{kind; params; body} -> (* assume kind = Curried *) + | Lfunction{params; body} -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in let to_compile = @@ -506,7 +506,7 @@ let rec comp_expr env exp sz cont = Stack.push to_compile functions_to_compile; comp_args env (List.map (fun n -> Lvar n) fv) sz (Kclosure(lbl, List.length fv) :: cont) - | Llet(str, id, arg, body) -> + | Llet(_str, id, arg, body) -> comp_expr env arg sz (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1) (add_pop 1 cont)) @@ -517,10 +517,10 @@ let rec comp_expr env exp sz cont = (* let rec of functions *) let fv = IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in - let rec_idents = List.map (fun (id, lam) -> id) decl in + let rec_idents = List.map (fun (id, _lam) -> id) decl in let rec comp_fun pos = function [] -> [] - | (id, Lfunction{kind; params; body}) :: rem -> + | (_id, Lfunction{params; body}) :: rem -> let lbl = new_label() in let to_compile = { params = params; body = body; label = lbl; free_vars = fv; @@ -538,39 +538,39 @@ let rec comp_expr env exp sz cont = List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in let rec comp_init new_env sz = function | [] -> comp_nonrec new_env sz ndecl decl_size - | (id, exp, RHS_floatblock blocksize) :: rem -> + | (id, _exp, RHS_floatblock blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy_float", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_block blocksize) :: rem -> + | (id, _exp, RHS_block blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_function (blocksize,arity)) :: rem -> + | (id, _exp, RHS_function (blocksize,arity)) :: rem -> Kconst(Const_base(Const_int arity)) :: Kpush :: Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy_function", 2) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (id, _exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem - | (id, exp, RHS_nonrec) :: rem -> + | (_id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) + | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) - | (id, exp, RHS_nonrec) :: rem -> + | (_id, _exp, RHS_nonrec) :: rem -> comp_rec new_env sz (i-1) rem in comp_init env sz decl_size diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index e77920b6d..4c16d65d8 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -89,19 +89,19 @@ module IdentSet = Lambda.IdentSet let missing_globals = ref IdentSet.empty -let is_required (rel, pos) = +let is_required (rel, _pos) = match rel with Reloc_setglobal id -> IdentSet.mem id !missing_globals | _ -> false -let add_required (rel, pos) = +let add_required (rel, _pos) = match rel with Reloc_getglobal id -> missing_globals := IdentSet.add id !missing_globals | _ -> () -let remove_required (rel, pos) = +let remove_required (rel, _pos) = match rel with Reloc_setglobal id -> missing_globals := IdentSet.remove id !missing_globals diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 869cab79e..3a3a4ac58 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -186,7 +186,7 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs let build_global_target oc target_name members mapping pos coercion = let components = List.map2 - (fun m (id1, id2) -> + (fun m (_id1, id2) -> match m.pm_kind with | PM_intf -> None | PM_impl _ -> Some id2) @@ -232,7 +232,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_final = pos_out oc in let imports = List.filter - (fun (name, crc) -> not (List.mem name unit_names)) + (fun (name, _crc) -> not (List.mem name unit_names)) (Bytelink.extract_crc_interfaces()) in let compunit = { cu_name = targetname; diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 061e09232..2beb0761b 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -94,7 +94,7 @@ let read_section_struct ic name = let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + List.fold_left (fun total (_name, len) -> total + len) 0 !section_table let reset () = section_table := []; diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b3011291c..054a17961 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -329,7 +329,7 @@ let make_key e = Lsequence (tr_rec env e1,tr_rec env e2) | Lassign (x,e) -> Lassign (x,tr_rec env e) - | Lsend (m,e1,e2,es,loc) -> + | Lsend (m,e1,e2,es,_loc) -> Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) | Lifused (id,e) -> Lifused (id,tr_rec env e) | Lletrec _|Lfunction _ @@ -365,7 +365,7 @@ let name_lambda strict arg fn = let name_lambda_list args fn = let rec name_list names = function [] -> fn (List.rev names) - | (Lvar id as arg) :: rem -> + | (Lvar _ as arg) :: rem -> name_list (arg :: names) rem | arg :: rem -> let id = Ident.create "let" in @@ -382,19 +382,19 @@ let iter f = function | Lconst _ -> () | Lapply{ap_func = fn; ap_args = args} -> f fn; List.iter f args - | Lfunction{kind; params; body} -> + | Lfunction{body} -> f body - | Llet(str, id, arg, body) -> + | Llet(_str, _id, arg, body) -> f arg; f body | Lletrec(decl, body) -> f body; - List.iter (fun (id, exp) -> f exp) decl - | Lprim(p, args) -> + List.iter (fun (_id, exp) -> f exp) decl + | Lprim(_p, args) -> List.iter f args | Lswitch(arg, sw) -> f arg; - List.iter (fun (key, case) -> f case) sw.sw_consts; - List.iter (fun (key, case) -> f case) sw.sw_blocks; + List.iter (fun (_key, case) -> f case) sw.sw_consts; + List.iter (fun (_key, case) -> f case) sw.sw_blocks; iter_opt f sw.sw_failaction | Lstringswitch (arg,cases,default) -> f arg ; @@ -402,9 +402,9 @@ let iter f = function iter_opt f default | Lstaticraise (_,args) -> List.iter f args - | Lstaticcatch(e1, (_,vars), e2) -> + | Lstaticcatch(e1, _, e2) -> f e1; f e2 - | Ltrywith(e1, exn, e2) -> + | Ltrywith(e1, _, e2) -> f e1; f e2 | Lifthenelse(e1, e2, e3) -> f e1; f e2; f e3 @@ -412,15 +412,15 @@ let iter f = function f e1; f e2 | Lwhile(e1, e2) -> f e1; f e2 - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(_v, e1, e2, _dir, e3) -> f e1; f e2; f e3 - | Lassign(id, e) -> + | Lassign(_, e) -> f e - | Lsend (k, met, obj, args, _) -> + | Lsend (_k, met, obj, args, _) -> List.iter f (met::obj::args) - | Levent (lam, evt) -> + | Levent (lam, _evt) -> f lam - | Lifused (v, e) -> + | Lifused (_v, e) -> f e @@ -436,19 +436,19 @@ let free_ids get l = iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction{kind; params; body} -> + Lfunction{params} -> List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet(str, id, arg, body) -> + | Llet(_str, id, _arg, _body) -> fv := IdentSet.remove id !fv - | Lletrec(decl, body) -> - List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl - | Lstaticcatch(e1, (_,vars), e2) -> + | Lletrec(decl, _body) -> + List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch(_e1, (_,vars), _e2) -> List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith(e1, exn, e2) -> + | Ltrywith(_e1, exn, _e2) -> fv := IdentSet.remove exn !fv - | Lfor(v, e1, e2, dir, e3) -> + | Lfor(v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv - | Lassign(id, e) -> + | Lassign(id, _e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ @@ -460,7 +460,7 @@ let free_variables l = free_ids (function Lvar id -> [id] | _ -> []) l let free_methods l = - free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l + free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l (* Check if an action has a "when" guard *) let raise_count = ref 0 @@ -479,9 +479,9 @@ let next_negative_raise_count () = let staticfail = Lstaticraise (0,[]) let rec is_guarded = function - | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true - | Llet(str, id, lam, body) -> is_guarded body - | Levent(lam, ev) -> is_guarded lam + | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true + | Llet(_str, _id, _lam, body) -> is_guarded body + | Levent(lam, _ev) -> is_guarded lam | _ -> false let rec patch_guarded patch = function @@ -498,9 +498,9 @@ let rec patch_guarded patch = function let rec transl_normal_path = function Pident id -> if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id - | Pdot(p, s, pos) -> + | Pdot(p, _s, pos) -> Lprim(Pfield pos, [transl_normal_path p]) - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Lambda.transl_path" (* Translation of value identifiers *) @@ -526,7 +526,7 @@ let subst_lambda s lam = let rec subst = function Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end - | Lconst sc as l -> l + | Lconst _ as l -> l | Lapply ap -> Lapply{ap with ap_func = subst ap.ap_func; ap_args = List.map subst ap.ap_args} @@ -566,8 +566,8 @@ let subst_lambda s lam = let rec map f lam = let lam = match lam with - | Lvar v -> lam - | Lconst cst -> lam + | Lvar _ -> lam + | Lconst _ -> lam | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; ap_inlined; ap_specialised } -> Lapply { diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 810063665..69e7354c8 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -72,7 +72,7 @@ let lshift {left=left ; right=right} = match right with | _ -> assert false let lforget {left=left ; right=right} = match right with -| x::xs -> {left=omega::left ; right=xs} +| _::xs -> {left=omega::left ; right=xs} | _ -> assert false let rec small_enough n = function @@ -174,7 +174,7 @@ let ctx_matcher p = | Cstr_extension _ -> let nargs = List.length omegas in (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) + | Tpat_construct (_, _cstr',args) when List.length args = nargs -> p,args @ rem | Tpat_any -> p,omegas @ rem @@ -396,7 +396,7 @@ type pm_half_compiled_info = let pretty_cases cases = List.iter - (fun ((ps),l) -> + (fun (ps,_l) -> List.iter (fun p -> Parmatch.top_pretty Format.str_formatter p ; @@ -1078,7 +1078,7 @@ and precompile_var args cls def k = match args with | [] -> assert false | _::((Lvar v as av,_) as arg)::rargs -> begin match cls with - | [ps,_] -> (* as splitted as it can *) + | [_] -> (* as splitted as it can *) dont_precompile_var args cls def k | _ -> (* Precompile *) @@ -1113,7 +1113,7 @@ and dont_precompile_var args cls def k = and is_exc p = match p.pat_desc with | Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 -| Tpat_alias (p,v,_) -> is_exc p +| Tpat_alias (p,_,_) -> is_exc p | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | _ -> false @@ -1325,7 +1325,7 @@ let matcher_constr cstr = match cstr.cstr_arity with | None, None -> raise NoMatch | Some r1, None -> r1 | None, Some r2 -> r2 - | Some (a1::rem1), Some (a2::_) -> + | Some (a1::_), Some (a2::_) -> {a1 with pat_loc = Location.none ; pat_desc = Tpat_or (a1, a2, None)}:: @@ -1347,7 +1347,7 @@ let matcher_constr cstr = match cstr.cstr_arity with let make_constr_matching p def ctx = function [] -> fatal_error "Matching.make_constr_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let cstr = pat_as_constr p in let newargs = if cstr.cstr_inlined <> None then @@ -1387,7 +1387,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with let make_variant_matching_constant p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_constant" - | ((arg, mut) :: argl) -> + | (_ :: argl) -> let def = make_default (matcher_variant_const lab) def and ctx = filter_ctx p ctx in {pm={ cases = []; args = argl ; default=def} ; @@ -1403,7 +1403,7 @@ let matcher_variant_nonconst lab p rem = match p.pat_desc with let make_variant_matching_nonconst p lab def ctx = function [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let def = make_default (matcher_variant_nonconst lab) def and ctx = filter_ctx p ctx in {pm= @@ -1431,7 +1431,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} = add (make_variant_matching_nonconst p lab def ctx) variants (=) (Cstr_block tag) (pat :: patl, action) al end - | cl -> [] + | _ -> [] in divide cl @@ -1562,7 +1562,7 @@ let inline_lazy_force arg loc = let make_lazy_matching def = function [] -> fatal_error "Matching.make_lazy_matching" - | (arg,mut) :: argl -> + | (arg,_mut) :: argl -> { cases = []; args = (inline_lazy_force arg Location.none, Strict) :: argl; @@ -1591,7 +1591,7 @@ let matcher_tuple arity p rem = match p.pat_desc with let make_tuple_matching arity def = function [] -> fatal_error "Matching.make_tuple_matching" - | (arg, mut) :: argl -> + | (arg, _mut) :: argl -> let rec make_args pos = if pos >= arity then argl @@ -1628,7 +1628,7 @@ let matcher_record num_fields p rem = match p.pat_desc with let make_record_matching all_labels def = function [] -> fatal_error "Matching.make_record_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let rec make_args pos = if pos >= Array.length all_labels then argl else begin let lbl = all_labels.(pos) in @@ -1675,7 +1675,7 @@ let matcher_array len p rem = match p.pat_desc with let make_array_matching kind p def ctx = function | [] -> fatal_error "Matching.make_array_matching" - | ((arg, mut) :: argl) -> + | ((arg, _mut) :: argl) -> let len = get_key_array p in let rec make_args pos = if pos >= len @@ -2018,7 +2018,7 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = let store = StoreExp.mk_store () in - let do_store tag act = + let do_store _tag act = let i = store.act_store act in (* @@ -2188,7 +2188,7 @@ let mk_failaction_pos partial seen ctx defs = | _,(pss,idef)::rem -> let now, later = List.partition - (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in + (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in match now with | [] -> scan_def env to_test rem | _ -> scan_def ((List.map fst now,idef)::env) later rem in @@ -2219,7 +2219,7 @@ let mk_failaction_pos partial seen ctx defs = end let combine_constant arg cst partial ctx def - (const_lambda_list, total, pats) = + (const_lambda_list, total, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = @@ -2411,7 +2411,7 @@ let call_switcher_variant_constr fail arg int_lambda_list = call_switcher fail (Lvar v) min_int max_int int_lambda_list) -let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = +let combine_variant row arg partial ctx def (tag_lambda_list, total1, _pats) = let row = Btype.row_repr row in let num_constr = ref 0 in if row.row_closed then @@ -2439,7 +2439,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = | None, Some act -> act | _,_ -> match (consts, nonconsts) with - | ([n, act1], [m, act2]) when fail=None -> + | ([_, act1], [_, act2]) when fail=None -> test_int_or_block arg act1 act2 | (_, []) -> (* One can compare integers and pointers *) make_test_sequence_variant_constant fail arg consts @@ -2464,7 +2464,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = let combine_array arg kind partial ctx def - (len_lambda_list, total1, pats) = + (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in @@ -2491,7 +2491,7 @@ let rec event_branch repr lam = | (Llet(str, id, lam, body), _) -> Llet(str, id, lam, event_branch repr body) | Lstaticraise _,_ -> lam - | (_, Some r) -> + | (_, Some _) -> Printlambda.lambda Format.str_formatter lam ; fatal_error ("Matching.event_branch: "^Format.flush_str_formatter ()) @@ -2663,10 +2663,10 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = (* To find reasonable names for variables *) let rec name_pattern default = function - (pat :: patl, action) :: rem -> + (pat :: _, _) :: rem -> begin match pat.pat_desc with Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> name_pattern default rem end | _ -> Ident.create default @@ -2760,7 +2760,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_no_test (divide_lazy (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_variant(lab, _, row) -> + | Tpat_variant(_, _, row) -> compile_test (compile_match repr partial) partial (divide_variant !row) (combine_variant !row arg partial) @@ -2879,7 +2879,7 @@ let check_total total lambda i handler_fun = Lstaticcatch(lambda, (i,[]), handler_fun()) end -let compile_matching loc repr handler_fun arg pat_act_list partial = +let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in match partial with | Partial -> @@ -2915,16 +2915,16 @@ let partial_function loc () = Const_base(Const_int char)]))])]) let for_function loc repr param pat_act_list partial = - compile_matching loc repr (partial_function loc) param pat_act_list partial + compile_matching repr (partial_function loc) param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None + compile_matching None (fun () -> Lprim(Praise Raise_reraise, [param])) param pat_act_list Partial let simple_for_let loc param pat body = - compile_matching loc None (partial_function loc) param [pat, body] Partial + compile_matching None (partial_function loc) param [pat, body] Partial (* Optimize binding of immediate tuples diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index fb7bdc00c..5608fdde7 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -222,9 +222,9 @@ let primitive ppf = function | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(unsafe, n, kind, layout) -> + | Pbigarrayref(unsafe, _n, kind, layout) -> print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, n, kind, layout) -> + | Pbigarrayset(unsafe, _n, kind, layout) -> print_bigarray "set" unsafe kind ppf layout | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n | Pstring_load_16(unsafe) -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index fe1d005be..6cc0f5342 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -26,11 +26,11 @@ exception Real_reference let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam - | Lconst cst as lam -> lam + | Lconst _ as lam -> lam | Lapply ap -> Lapply{ap with ap_func = eliminate_ref id ap.ap_func; ap_args = List.map (eliminate_ref id) ap.ap_args} - | Lfunction{kind; params; body} as lam -> + | Lfunction _ as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference else lam @@ -111,13 +111,13 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args - | Lfunction{kind; params; body = l} -> count l - | Llet(str, v, l1, l2) -> + | Lfunction {body} -> count body + | Llet(_str, _v, l1, l2) -> count l2; count l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count l) bindings; + List.iter (fun (_v, l) -> count l) bindings; count body - | Lprim(p, ll) -> List.iter count ll + | Lprim(_p, ll) -> List.iter count ll | Lswitch(l, sw) -> count_default sw ; count l; @@ -150,15 +150,15 @@ let simplify_exits lam = l2 will be removed, so don't count its exits *) if count_exit i > 0 then count l2 - | Ltrywith(l1, v, l2) -> count l1; count l2 + | Ltrywith(l1, _v, l2) -> count l1; count l2 | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> count l - | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) + | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 + | Lassign(_v, l) -> count l + | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l - | Lifused(v, l) -> count l + | Lifused(_v, l) -> count l and count_default sw = match sw.sw_failaction with | None -> () @@ -267,7 +267,7 @@ let simplify_exits lam = with | Not_found -> Lstaticraise (i,ls) end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> + | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 | Lstaticcatch (l1,(i,xs),l2) -> @@ -352,7 +352,7 @@ let simplify_lets lam = () in let rec count bv = function - | Lconst cst -> () + | Lconst _ -> () | Lvar v -> use_var bv v 1 | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} @@ -364,9 +364,9 @@ let simplify_lets lam = count bv (beta_reduce params body args) | Lapply{ap_func = l1; ap_args = ll} -> count bv l1; List.iter (count bv) ll - | Lfunction{kind; params; body = l} -> - count Tbl.empty l - | Llet(str, v, Lvar w, l2) when optimize -> + | Lfunction {body} -> + count Tbl.empty body + | Llet(_str, v, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) count (bind_var bv v) l2; @@ -376,9 +376,9 @@ let simplify_lets lam = (* If v is unused, l1 will be removed, so don't count its variables *) if str = Strict || count_var v > 0 then count bv l1 | Lletrec(bindings, body) -> - List.iter (fun (v, l) -> count bv l) bindings; + List.iter (fun (_v, l) -> count bv l) bindings; count bv body - | Lprim(p, ll) -> List.iter (count bv) ll + | Lprim(_p, ll) -> List.iter (count bv) ll | Lswitch(l, sw) -> count_default bv sw ; count bv l; @@ -395,14 +395,14 @@ let simplify_lets lam = end | None -> () end - | Lstaticraise (i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 - | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 + | Lstaticraise (_i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 | Lsequence(l1, l2) -> count bv l1; count bv l2 | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2 - | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 - | Lassign(v, l) -> + | Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3 + | Lassign(_v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count bv l @@ -447,7 +447,7 @@ let simplify_lets lam = with Not_found -> l end - | Lconst cst as l -> l + | Lconst _ as l -> l | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) @@ -465,7 +465,7 @@ let simplify_lets lam = | body -> Lfunction{kind; params; body; attr} end - | Llet(str, v, Lvar w, l2) when optimize -> + | Llet(_str, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody) @@ -481,12 +481,12 @@ let simplify_lets lam = begin match count_var v with 0 -> simplif l2 | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | n -> Llet(Alias, v, simplif l1, simplif l2) + | _ -> Llet(Alias, v, simplif l1, simplif l2) end | Llet(StrictOpt, v, l1, l2) -> begin match count_var v with 0 -> simplif l2 - | n -> mklet(Alias, v, simplif l1, simplif l2) + | _ -> mklet(Alias, v, simplif l1, simplif l2) end | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> @@ -531,7 +531,7 @@ let simplify_lets lam = (* Tail call info in annotation files *) let is_tail_native_heuristic : (int -> bool) ref = - ref (fun n -> true) + ref (fun _ -> true) let rec emit_tail_infos is_tail lambda = let call_kind args = diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index dfcf77e39..fbde44521 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -390,13 +390,13 @@ let rec opt_count top cases = if lcases < !cut then enum top cases else if lcases < !more_cut then - heuristic top cases + heuristic cases else - divide top cases in + divide cases in Hashtbl.add t key r ; r -and divide top cases = +and divide cases = let lcases = Array.length cases in let m = lcases/2 in let _,left,right = coupe cases m in @@ -412,10 +412,10 @@ and divide top cases = add_test cm cml ; Sep m,(cm, ci) -and heuristic top cases = +and heuristic cases = let lcases = Array.length cases in - let sep,csep = divide false cases + let sep,csep = divide cases and inter,cinter = if !ok_inter then begin @@ -589,7 +589,7 @@ and enum top cases = else begin - let w,c = opt_count false cases in + let w,_c = opt_count false cases in (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" @@ -664,13 +664,13 @@ let switch_min = ref 3 (* Particular case 0, 1, 2 *) let particular_case cases i j = j-i = 2 && - (let l1,h1,act1 = cases.(i) - and l2,h2,act2 = cases.(i+1) + (let l1,_h1,act1 = cases.(i) + and l2,_h2,_act2 = cases.(i+1) and l3,h3,act3 = cases.(i+2) in l1+1=l2 && l2+1=l3 && l3=h3 && act1 <> act3) -let approx_count cases i j n_actions = +let approx_count cases i j = let l = j-i+1 in if l < !cut then let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in @@ -680,12 +680,12 @@ let approx_count cases i j n_actions = (* Sends back a boolean that says whether is switch is worth or not *) -let dense {cases=cases ; actions=actions} i j = +let dense {cases} i j = if i=j then true else let l,_,_ = cases.(i) and _,h,_ = cases.(j) in - let ntests = approx_count cases i j (Array.length actions) in + let ntests = approx_count cases i j in (* (ntests+1) >= theta * (h-l+1) *) @@ -701,8 +701,8 @@ let dense {cases=cases ; actions=actions} i j = Software Practice and Exprience Vol. 24(2) 233 (Feb 1994) *) -let comp_clusters ({cases=cases ; actions=actions} as s) = - let len = Array.length cases in +let comp_clusters s = + let len = Array.length s.cases in let min_clusters = Array.make len max_int and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 22810cfc1..8e96f498b 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -332,12 +332,12 @@ let check_global_initialized patchlist = List.fold_left (fun accu rel -> match rel with - (Reloc_setglobal id, pos) -> id :: accu + (Reloc_setglobal id, _pos) -> id :: accu | _ -> accu) [] patchlist in (* Then check that all referenced, not defined globals have a value *) let check_reference = function - (Reloc_getglobal id, pos) -> + (Reloc_getglobal id, _pos) -> if not (List.mem id defined_globals) && Obj.is_int (get_global_value id) then raise (Error(Uninitialized_global(Ident.name id))) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index a24780998..07f99ef15 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -93,7 +93,7 @@ let meths_super tbl meths inh_meths = let bind_super tbl (vals, meths) cl_init = transl_vals tbl false StrictOpt vals - (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) + (List.fold_right (fun (_nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) let create_object cl obj init = @@ -117,7 +117,7 @@ let create_object cl obj init = let name_pattern default p = match p.pat_desc with | Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> Ident.create default let normalize_cl_path cl path = @@ -192,12 +192,12 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_constraint (cl, _, vals, pub_meths, concr_meths) -> + | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) -> build_object_init cl_table obj params inh_init obj_init cl let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (_rec_flag, _defs, vals, cl) -> let vals = List.map (fun (id, _, e) -> id,e) vals in build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids | _ -> @@ -206,7 +206,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let obj = if ids = [] then lambda_unit else Lvar self in let envs = if top then None else Some env in let ((_,inh_init), obj_init) = - build_object_init cl_table obj params (envs,[]) (copy_env env) cl in + build_object_init cl_table obj params (envs,[]) copy_env cl in let obj_init = if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) @@ -232,7 +232,7 @@ let bind_methods tbl meths vals cl_init = mkappl (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right - (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) + (fun (_lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) (methl @ vals) cl_init) let output_methods tbl methods lam = @@ -262,7 +262,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> begin match inh_init with - (obj_init, path')::inh_init -> + (obj_init, _path')::inh_init -> let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, Llet (Strict, obj_init, @@ -319,15 +319,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = in let cl_init = output_methods cla methods cl_init in (inh_init, bind_methods cla str.cstr_meths values cl_init) - | Tcl_fun (_, pat, vals, cl, _) -> + | Tcl_fun (_, _pat, vals, cl, _) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in let vals = List.map bind_id_as_val vals in (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_apply (cl, exprs) -> + | Tcl_apply (cl, _exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (_rec_flag, _defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in @@ -381,7 +381,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let rec build_class_lets cl ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl') -> + Tcl_let (rec_flag, defs, _vals, cl') -> let env, wrap = build_class_lets cl' [] in (env, fun x -> let lam = Translcore.transl_let rec_flag defs (wrap x) in @@ -430,7 +430,7 @@ let rec transl_class_rebind obj_init cl vf = | Tcl_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, vals, cl) -> + | Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tcl_structure _ -> raise Exit @@ -446,7 +446,7 @@ let rec transl_class_rebind obj_init cl vf = let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> + Tcl_let (rec_flag, defs, _vals, cl) -> let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> @@ -677,7 +677,7 @@ let transl_class ids cl_id pub_meths cl vflag = in let new_ids_init = ref [] in let env1 = Ident.create "env" and env1' = Ident.create "env'" in - let copy_env envs self = + let copy_env self = if top then lambda_unit else Lifused(env2, Lprim(Parraysetu Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index d34c9f65a..e39119ab5 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -37,11 +37,11 @@ let use_dup_for_constant_arrays_bigger_than = 4 (* Forward declaration -- to be filled in by Translmod.transl_module *) let transl_module = - ref((fun cc rootpath modl -> assert false) : + ref((fun _cc _rootpath _modl -> assert false) : module_coercion -> Path.t option -> module_expr -> lambda) let transl_object = - ref (fun id s cl -> assert false : + ref (fun _id _s _cl -> assert false : Ident.t -> string list -> class_expr -> lambda) (* Compile an exception/extension definition *) @@ -57,11 +57,11 @@ let transl_extension_constructor env path ext = | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) in match ext.ext_kind with - Text_decl(args, ret) -> + Text_decl _ -> Lprim (Pmakeblock (Obj.object_tag, Immutable), [Lconst (Const_base (Const_string (name, None))); Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])]) - | Text_rebind(path, lid) -> + | Text_rebind(path, _lid) -> transl_path ~loc:ext.ext_loc env path (* Translation of primitives *) @@ -325,9 +325,6 @@ let primitives_table = create_hashtable 57 [ "%opaque", Popaque; ] -let prim_obj_dup = - Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true - let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc @@ -365,7 +362,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor = intcomp else match is_function_type env ty with - | Some (lhs,rhs) -> specialize_comparison table env lhs + | Some (lhs,_rhs) -> specialize_comparison table env lhs | None -> gencomp with Not_found -> let p = find_primitive loc p.prim_name in @@ -377,7 +374,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor = | Some (p2, _) -> [p1;p2] in match (p, params) with - (Psetfield(n, _, init), [p1; p2]) -> + (Psetfield(n, _, init), [_p1; p2]) -> Psetfield(n, maybe_pointer_type env p2, init) | (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p) | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1) @@ -397,7 +394,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor = (* Eta-expand a primitive *) let used_primitives = Hashtbl.create 7 -let add_used_primitive loc p env path = +let add_used_primitive loc env path = match path with Some (Path.Pdot _ as path) -> let path = Env.normalize_path (Some loc) env path in @@ -410,7 +407,7 @@ let transl_primitive loc p env ty path = let prim = try specialize_primitive loc p env ty ~has_constant_constructor:false with Not_found -> - add_used_primitive loc p env path; + add_used_primitive loc env path; Pccall p in match prim with @@ -452,7 +449,7 @@ let transl_primitive_application loc prim env ty path args = with Not_found -> if String.length prim_name > 0 && prim_name.[0] = '%' then raise(Error(loc, Unknown_builtin_primitive prim_name)); - add_used_primitive loc prim env path; + add_used_primitive loc env path; Pccall prim @@ -463,13 +460,13 @@ let check_recursive_lambda idlist lam = | Lvar v -> not (List.mem v idlist) | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + List.for_all (fun (_id, arg) -> check idlist' arg) bindings && check_top idlist' body - | Lprim (Pmakearray (Pgenarray, _), args) -> false + | Lprim (Pmakearray (Pgenarray, _), _) -> false | Lprim (Pmakearray (Pfloatarray, _), args) -> List.for_all (check idlist) args | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2 @@ -478,16 +475,16 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true - | Lfunction{kind; params; body} -> true + | Lfunction _ -> true | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> true - | Llet(str, id, arg, body) -> + | Llet(_str, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body | Lletrec(bindings, body) -> let idlist' = add_letrec bindings idlist in - List.for_all (fun (id, arg) -> check idlist' arg) bindings && + List.for_all (fun (_id, arg) -> check idlist' arg) bindings && check idlist' body - | Lprim(Pmakeblock(tag, mut), args) -> + | Lprim(Pmakeblock _, args) -> List.for_all (check idlist) args | Lprim (Pmakearray (Pfloatarray, _), _) -> false | Lprim (Pmakearray _, args) -> @@ -544,7 +541,7 @@ let rec name_pattern default = function | {c_lhs=p; _} :: rem -> match p.pat_desc with Tpat_var (id, _) -> id - | Tpat_alias(p, id, _) -> id + | Tpat_alias(_, id, _) -> id | _ -> name_pattern default rem (* Push the default values under the functional abstractions *) @@ -701,7 +698,7 @@ and transl_exp0 e = [Lvar cache; Lvar pos], e.exp_loc)} else transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path) - | Texp_ident(path, _, {val_kind = Val_anc _}) -> + | Texp_ident(_, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> transl_path ~loc:e.exp_loc e.exp_env path @@ -1172,7 +1169,7 @@ and transl_function loc untuplify_fn repr partial cases = (fun {c_lhs; c_guard; c_rhs} -> (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) cases in - let params = List.map (fun p -> Ident.create "param") pl in + let params = List.map (fun _ -> Ident.create "param") pl in ((Tupled, params), Matching.for_tupled_function loc params (transl_tupled_cases pats_expr_list) partial) @@ -1212,7 +1209,7 @@ and transl_let rec_flag pat_expr_list body = | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in - let transl_case {vb_pat=pat; vb_expr=expr; vb_attributes; vb_loc} id = + let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = let lam = transl_exp expr in let lam = Translattribute.add_inline_attribute lam vb_loc @@ -1246,7 +1243,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = let init_id = Ident.create "init" in begin match opt_init_expr with None -> () - | Some init_expr -> + | Some _ -> for i = 0 to Array.length all_labels - 1 do let access = match all_labels.(i).lbl_repres with diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 599cd5c0f..b68d5962d 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -91,7 +91,7 @@ let rec apply_coercion strict restr arg = transl_primitive pc_loc pc_desc pc_env pc_type None | Tcoerce_alias (path, cc) -> name_lambda strict arg - (fun id -> apply_coercion Alias cc (transl_normal_path path)) + (fun _ -> apply_coercion Alias cc (transl_normal_path path)) and apply_coercion_field get_field (pos, cc) = apply_coercion Alias cc (get_field pos) @@ -192,12 +192,12 @@ let init_shape modl = Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Mty_functor(id, arg, res) -> + | Mty_functor _ -> raise Not_found (* can we do better? *) and init_shape_struct env sg = match sg with [] -> [] - | Sig_value(id, vdesc) :: rem -> + | Sig_value(_id, vdesc) :: rem -> let init_v = match Ctype.expand_head env vdesc.val_type with {desc = Tarrow(_,_,_,_)} -> @@ -208,17 +208,17 @@ let init_shape modl = init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext(id, ext, _) :: rem -> + | Sig_typext _ :: _ -> raise Not_found | Sig_module(id, md, _) :: rem -> init_shape_mod env md.md_type :: init_shape_struct (Env.add_module_declaration id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class(id, cdecl, _) :: rem -> + | Sig_class _ :: rem -> Const_pointer 2 (* camlinternalMod.Class *) :: init_shape_struct env rem - | Sig_class_type(id, ctyp, _) :: rem -> + | Sig_class_type _ :: rem -> init_shape_struct env rem in try @@ -267,9 +267,9 @@ let eval_rec_bindings bindings cont = let rec bind_inits = function [] -> bind_strict bindings - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> bind_inits rem - | (id, Some(loc, shape), rhs) :: rem -> + | (id, Some(loc, shape), _rhs) :: rem -> Llet(Strict, id, Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; @@ -283,14 +283,14 @@ let eval_rec_bindings bindings cont = patch_forwards bindings | (id, None, rhs) :: rem -> Llet(Strict, id, rhs, bind_strict rem) - | (id, Some(loc, shape), rhs) :: rem -> + | (_id, Some _, _rhs) :: rem -> bind_strict rem and patch_forwards = function [] -> cont - | (id, None, rhs) :: rem -> + | (_id, None, _rhs) :: rem -> patch_forwards rem - | (id, Some(loc, shape), rhs) :: rem -> + | (id, Some(_loc, shape), rhs) :: rem -> Lsequence(Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; ap_func=mod_prim "update_mod"; @@ -319,9 +319,9 @@ let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -349,7 +349,7 @@ let rec transl_module cc rootpath mexp = (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> fst (transl_struct [] cc rootpath str) - | Tmod_functor( param, _, mty, body) -> + | Tmod_functor(param, _, _, body) -> let bodypath = functor_path rootpath param in let inline_attribute = Translattribute.get_inline_attribute mexp.mod_attributes @@ -387,7 +387,7 @@ let rec transl_module cc rootpath mexp = ap_args=[transl_module ccarg None arg]; ap_inlined=inlined_attribute; ap_specialised=Default_specialise}) - | Tmod_constraint(arg, mty, _, ccarg) -> + | Tmod_constraint(arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> apply_coercion Strict cc (Translcore.transl_exp arg) @@ -456,7 +456,7 @@ and transl_structure fields cc rootpath final_env = function | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure fields cc rootpath final_env rem - | Tstr_type(_, decls) -> + | Tstr_type _ -> transl_structure fields cc rootpath final_env rem | Tstr_typext(tyext) -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in @@ -558,7 +558,7 @@ let wrap_globals body = let add_global id req = if IdentSet.mem id globals then req else IdentSet.add id req in let required = - Hashtbl.fold (fun path loc -> add_global (Path.head path)) + Hashtbl.fold (fun path _ -> add_global (Path.head path)) used_primitives IdentSet.empty in let required = @@ -600,11 +600,11 @@ let rec defined_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _) -> defined_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> defined_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive desc -> defined_idents rem - | Tstr_type (_, decls) -> defined_idents rem + | Tstr_primitive _ -> defined_idents rem + | Tstr_type _ -> defined_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ defined_idents rem @@ -616,7 +616,7 @@ let rec defined_idents = function | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type cl_list -> defined_idents rem + | Tstr_class_type _ -> defined_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ defined_idents rem | Tstr_attribute _ -> defined_idents rem @@ -627,17 +627,17 @@ let rec more_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _attrs) -> more_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem + | Tstr_eval _ -> more_idents rem + | Tstr_value _ -> more_idents rem | Tstr_primitive _ -> more_idents rem - | Tstr_type (_, decls) -> more_idents rem - | Tstr_typext tyext -> more_idents rem + | Tstr_type _ -> more_idents rem + | Tstr_typext _ -> more_idents rem | Tstr_exception _ -> more_idents rem - | Tstr_recmodule decls -> more_idents rem + | Tstr_recmodule _ -> more_idents rem | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem - | Tstr_class cl_list -> more_idents rem - | Tstr_class_type cl_list -> more_idents rem + | Tstr_class _ -> more_idents rem + | Tstr_class_type _ -> more_idents rem | Tstr_include _ -> more_idents rem | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} | Tstr_module{mb_expr={mod_desc = @@ -651,11 +651,11 @@ and all_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval (expr, _attrs) -> all_idents rem - | Tstr_value(rec_flag, pat_expr_list) -> + | Tstr_eval _ -> all_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem | Tstr_primitive _ -> all_idents rem - | Tstr_type (_, decls) -> all_idents rem + | Tstr_type _ -> all_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ all_idents rem @@ -666,7 +666,7 @@ and all_idents = function | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem - | Tstr_class_type cl_list -> all_idents rem + | Tstr_class_type _ -> all_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ all_idents rem | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} @@ -717,7 +717,7 @@ let transl_store_structure glob map prims str = | Tstr_primitive descr -> record_primitive descr.val_val; transl_store rootpath subst rem - | Tstr_type(_, decls) -> + | Tstr_type _ -> transl_store rootpath subst rem | Tstr_typext(tyext) -> let ids = @@ -900,7 +900,7 @@ let build_ident_map restr idlist more_ids = let rec export_map pos map prims undef = function [] -> natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> + | (_source_pos, Tcoerce_primitive p) :: rem -> export_map (pos + 1) map ((pos, p) :: prims) undef rem | (source_pos, cc) :: rem -> let id = idarray.(source_pos) in @@ -1061,7 +1061,7 @@ let get_component = function None -> Lconst const_unit | Some id -> Lprim(Pgetglobal id, []) -let transl_package_flambda component_names target_name coercion = +let transl_package_flambda component_names coercion = let size = match coercion with | Tcoerce_none -> List.length component_names @@ -1108,7 +1108,7 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); get_component id])) 0 component_names) - | Tcoerce_structure (pos_cc_list, id_pos_list) -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> let components = Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in @@ -1116,7 +1116,7 @@ let transl_store_package component_names target_name coercion = (List.length pos_cc_list, Llet (Strict, blk, apply_coercion Strict coercion components, make_sequence - (fun pos id -> + (fun pos _id -> Lprim(Psetfield(pos, Pointer, Initialization), [Lprim(Pgetglobal target_name, []); Lprim(Pfield pos, [Lvar blk])])) diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 3628a9981..cd070df15 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -34,7 +34,7 @@ val transl_store_package: Ident.t option list -> Ident.t -> module_coercion -> int * lambda val transl_package_flambda: - Ident.t option list -> Ident.t -> module_coercion -> int * lambda + Ident.t option list -> module_coercion -> int * lambda val toplevel_name: Ident.t -> string val nat_toplevel_name: Ident.t -> Ident.t * int diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 1e860502a..490046dd7 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -33,7 +33,7 @@ let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 let share c = match c with - Const_block (n, l) when l <> [] -> + Const_block (_n, l) when l <> [] -> begin try Lvar (Hashtbl.find consts c) with Not_found -> diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 60aff406f..ebd9c62e4 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -48,7 +48,7 @@ let array_element_kind env ty = match scrape env ty with | Tvar _ | Tunivar _ -> Pgenarray - | Tconstr(p, args, abbrev) -> + | Tconstr(p, _args, _abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then Pintarray else if Path.same p Predef.path_float then @@ -120,7 +120,7 @@ let layout_table = let bigarray_type_kind_and_layout env typ = match scrape env typ with - | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> + | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, bigarray_decode_type env layout_type layout_table Pbigarray_unknown_layout) diff --git a/driver/compenv.ml b/driver/compenv.ml index cbdb59c41..d9d7779e5 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -158,6 +158,7 @@ let int_option_setter ppf name option s = (Warnings.Bad_env_variable ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name)) +(* let float_setter ppf name option s = try option := float_of_string s @@ -165,6 +166,7 @@ let float_setter ppf name option s = Location.print_warning Location.none ppf (Warnings.Bad_env_variable ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name)) +*) let check_bool ppf name s = match s with diff --git a/driver/optmain.ml b/driver/optmain.ml index 4c17c1161..fa7e27e7b 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -114,39 +114,48 @@ module Options = Main_args.Make_optcomp_options (struct let _I dir = include_dirs := dir :: !include_dirs let _impl = impl let _inline spec = - Float_arg_helper.parse spec ~update:inline_threshold - ~help_text:"Syntax: -inline | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline | =[,...]" inline_threshold let _inline_toplevel spec = - Int_arg_helper.parse spec ~update:inline_toplevel_threshold - ~help_text:"Syntax: -inline-toplevel | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-toplevel | =[,...]" + inline_toplevel_threshold let _inlining_report () = inlining_report := true let _dump_pass pass = set_dumped_pass pass true let _rounds n = simplify_rounds := Some n let _inline_max_unroll spec = - Int_arg_helper.parse spec ~update:inline_max_unroll - ~help_text:"Syntax: -inline-max-unroll | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-unroll | =[,...]" + inline_max_unroll let _classic_inlining () = classic_inlining := true let _inline_call_cost spec = - Int_arg_helper.parse spec ~update:inline_call_cost - ~help_text:"Syntax: -inline-call-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-call-cost | =[,...]" + inline_call_cost let _inline_alloc_cost spec = - Int_arg_helper.parse spec ~update:inline_alloc_cost - ~help_text:"Syntax: -inline-alloc-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-alloc-cost | =[,...]" + inline_alloc_cost let _inline_prim_cost spec = - Int_arg_helper.parse spec ~update:inline_prim_cost - ~help_text:"Syntax: -inline-prim-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-prim-cost | =[,...]" + inline_prim_cost let _inline_branch_cost spec = - Int_arg_helper.parse spec ~update:inline_branch_cost - ~help_text:"Syntax: -inline-branch-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-branch-cost | =[,...]" + inline_branch_cost let _inline_indirect_cost spec = - Int_arg_helper.parse spec ~update:inline_indirect_cost - ~help_text:"Syntax: -inline-indirect-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-indirect-cost | =[,...]" + inline_indirect_cost let _inline_lifting_benefit spec = - Int_arg_helper.parse spec ~update:inline_lifting_benefit - ~help_text:"Syntax: -inline-lifting-benefit | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-lifting-benefit | =[,...]" + inline_lifting_benefit let _inline_branch_factor spec = - Float_arg_helper.parse spec ~update:inline_branch_factor - ~help_text:"Syntax: -inline-branch-factor | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline-branch-factor | =[,...]" + inline_branch_factor let _intf = intf let _intf_suffix s = Config.interface_suffix := s let _keep_docs = set keep_docs @@ -154,8 +163,9 @@ module Options = Main_args.Make_optcomp_options (struct let _labels = clear classic let _linkall = set link_everything let _inline_max_depth spec = - Int_arg_helper.parse spec ~update:inline_max_depth - ~help_text:"Syntax: -inline-max-depth | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-depth | =[,...]" + inline_max_depth let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors let _no_float_const_prop = clear float_const_prop diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 4068af7f0..4f4dceac1 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -98,13 +98,13 @@ module T = struct | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl | Ptyp_constr (lid, tl) -> iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_object (l, o) -> + | Ptyp_object (l, _o) -> let f (_, a, t) = sub.attributes sub a; sub.typ sub t in List.iter f l | Ptyp_class (lid, tl) -> iter_loc sub lid; List.iter (sub.typ sub) tl | Ptyp_alias (t, _) -> sub.typ sub t - | Ptyp_variant (rl, b, ll) -> + | Ptyp_variant (rl, _b, _ll) -> List.iter (row_field sub) rl | Ptyp_poly (_, t) -> sub.typ sub t | Ptyp_package (lid, l) -> @@ -115,7 +115,7 @@ module T = struct let iter_type_declaration sub {ptype_name; ptype_params; ptype_cstrs; ptype_kind; - ptype_private; + ptype_private = _; ptype_manifest; ptype_attributes; ptype_loc} = @@ -144,7 +144,7 @@ module T = struct let iter_type_extension sub {ptyext_path; ptyext_params; ptyext_constructors; - ptyext_private; + ptyext_private = _; ptyext_attributes} = iter_loc sub ptyext_path; List.iter (sub.extension_constructor sub) ptyext_constructors; @@ -189,8 +189,8 @@ module CT = struct sub.attributes sub attrs; match desc with | Pctf_inherit ct -> sub.class_type sub ct - | Pctf_val (s, m, v, t) -> sub.typ sub t - | Pctf_method (s, p, v, t) -> sub.typ sub t + | Pctf_val (_s, _m, _v, t) -> sub.typ sub t + | Pctf_method (_s, _p, _v, t) -> sub.typ sub t | Pctf_constraint (t1, t2) -> sub.typ sub t1; sub.typ sub t2 | Pctf_attribute x -> sub.attribute sub x @@ -234,7 +234,7 @@ module MT = struct sub.location sub loc; match desc with | Psig_value vd -> sub.value_description sub vd - | Psig_type (rf, l) -> List.iter (sub.type_declaration sub) l + | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Psig_typext te -> sub.type_extension sub te | Psig_exception ed -> sub.extension_constructor sub ed | Psig_module x -> sub.module_declaration sub x @@ -277,9 +277,9 @@ module M = struct match desc with | Pstr_eval (x, attrs) -> sub.expr sub x; sub.attributes sub attrs - | Pstr_value (r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs | Pstr_primitive vd -> sub.value_description sub vd - | Pstr_type (rf, l) -> List.iter (sub.type_declaration sub) l + | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l | Pstr_typext te -> sub.type_extension sub te | Pstr_exception ed -> sub.extension_constructor sub ed | Pstr_module x -> sub.module_binding sub x @@ -303,11 +303,11 @@ module E = struct sub.attributes sub attrs; match desc with | Pexp_ident x -> iter_loc sub x - | Pexp_constant x -> () - | Pexp_let (r, vbs, e) -> + | Pexp_constant _ -> () + | Pexp_let (_r, vbs, e) -> List.iter (sub.value_binding sub) vbs; sub.expr sub e - | Pexp_fun (lab, def, p, e) -> + | Pexp_fun (_lab, def, p, e) -> iter_opt (sub.expr sub) def; sub.pat sub p; sub.expr sub e @@ -320,7 +320,7 @@ module E = struct | Pexp_tuple el -> List.iter (sub.expr sub) el | Pexp_construct (lid, arg) -> iter_loc sub lid; iter_opt (sub.expr sub) arg - | Pexp_variant (lab, eo) -> + | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) -> List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; @@ -338,7 +338,7 @@ module E = struct sub.expr sub e1; sub.expr sub e2 | Pexp_while (e1, e2) -> sub.expr sub e1; sub.expr sub e2 - | Pexp_for (p, e1, e2, d, e3) -> + | Pexp_for (p, e1, e2, _d, e3) -> sub.pat sub p; sub.expr sub e1; sub.expr sub e2; sub.expr sub e3 | Pexp_coerce (e, t1, t2) -> @@ -346,7 +346,7 @@ module E = struct sub.typ sub t2 | Pexp_constraint (e, t) -> sub.expr sub e; sub.typ sub t - | Pexp_send (e, s) -> sub.expr sub e + | Pexp_send (e, _s) -> sub.expr sub e | Pexp_new lid -> iter_loc sub lid | Pexp_setinstvar (s, e) -> iter_loc sub s; sub.expr sub e @@ -363,9 +363,9 @@ module E = struct | Pexp_poly (e, t) -> sub.expr sub e; iter_opt (sub.typ sub) t | Pexp_object cls -> sub.class_structure sub cls - | Pexp_newtype (s, e) -> sub.expr sub e + | Pexp_newtype (_s, e) -> sub.expr sub e | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (ovf, lid, e) -> + | Pexp_open (_ovf, lid, e) -> iter_loc sub lid; sub.expr sub e | Pexp_extension x -> sub.extension sub x | Pexp_unreachable -> () @@ -381,13 +381,13 @@ module P = struct | Ppat_any -> () | Ppat_var s -> iter_loc sub s | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s - | Ppat_constant c -> () - | Ppat_interval (c1, c2) -> () + | Ppat_constant _ -> () + | Ppat_interval _ -> () | Ppat_tuple pl -> List.iter (sub.pat sub) pl | Ppat_construct (l, p) -> iter_loc sub l; iter_opt (sub.pat sub) p - | Ppat_variant (l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, cf) -> + | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p + | Ppat_record (lpl, _cf) -> List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl | Ppat_array pl -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 @@ -411,14 +411,14 @@ module CE = struct iter_loc sub lid; List.iter (sub.typ sub) tys | Pcl_structure s -> sub.class_structure sub s - | Pcl_fun (lab, e, p, ce) -> + | Pcl_fun (_lab, e, p, ce) -> iter_opt (sub.expr sub) e; sub.pat sub p; sub.class_expr sub ce | Pcl_apply (ce, l) -> sub.class_expr sub ce; List.iter (iter_snd (sub.expr sub)) l - | Pcl_let (r, vbs, ce) -> + | Pcl_let (_r, vbs, ce) -> List.iter (sub.value_binding sub) vbs; sub.class_expr sub ce | Pcl_constraint (ce, ct) -> @@ -426,16 +426,16 @@ module CE = struct | Pcl_extension x -> sub.extension sub x let iter_kind sub = function - | Cfk_concrete (o, e) -> sub.expr sub e + | Cfk_concrete (_o, e) -> sub.expr sub e | Cfk_virtual t -> sub.typ sub t let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; match desc with - | Pcf_inherit (o, ce, s) -> sub.class_expr sub ce - | Pcf_val (s, m, k) -> iter_loc sub s; iter_kind sub k - | Pcf_method (s, p, k) -> + | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce + | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k + | Pcf_method (s, _p, k) -> iter_loc sub s; iter_kind sub k | Pcf_constraint (t1, t2) -> sub.typ sub t1; sub.typ sub t2 @@ -447,7 +447,7 @@ module CE = struct sub.pat sub pcstr_self; List.iter (sub.class_field sub) pcstr_fields - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; pci_loc; pci_attributes} = List.iter (iter_fst (sub.typ sub)) pl; iter_loc sub pci_name; @@ -487,7 +487,7 @@ let default_iterator = type_extension = T.iter_type_extension; extension_constructor = T.iter_extension_constructor; value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; + (fun this {pval_name; pval_type; pval_prim = _; pval_loc; pval_attributes} -> iter_loc this pval_name; this.typ this pval_type; @@ -523,7 +523,7 @@ let default_iterator = open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> iter_loc this popen_lid; this.location this popen_loc; this.attributes this popen_attributes @@ -564,7 +564,7 @@ let default_iterator = ); label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes} -> iter_loc this pld_name; this.typ this pld_type; this.location this pld_loc; @@ -579,7 +579,7 @@ let default_iterator = this.expr this pc_rhs ); - location = (fun this l -> ()); + location = (fun _this _l -> ()); extension = (fun this (s, e) -> iter_loc this s; this.payload this e); attribute = (fun this (s, e) -> iter_loc this s; this.payload this e); diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 3c009a7fe..cd320d3c4 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -617,7 +617,7 @@ let default_mapper = - location = (fun this l -> l); + location = (fun _this l -> l); extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index 9e452ce12..d4ac82915 100755 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -32,7 +32,7 @@ let rec error_of_extension ext = match inner with | {pstr_desc=Pstr_extension (ext, _)} :: rest -> error_of_extension ext :: sub_from rest - | {pstr_loc} :: rest -> + | _ :: rest -> (Location.errorf ~loc "Invalid syntax for sub-error of extension '%s'." txt) :: sub_from rest diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml index dd420a0cf..1f86c2da2 100644 --- a/parsing/docstrings.ml +++ b/parsing/docstrings.ml @@ -151,7 +151,7 @@ let get_docstring ~info dsl = let rec loop = function | [] -> None | {ds_attached = Info; _} :: rest -> loop rest - | ds :: rest -> + | ds :: _ -> ds.ds_attached <- if info then Info else Docs; Some ds in diff --git a/parsing/location.ml b/parsing/location.ml index ef9b2839f..2a4badc05 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -390,7 +390,7 @@ let error_of_exn exn = let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) = let highlighted = if if_highlight <> "" then - let rec collect_locs locs {loc; sub; if_highlight; _} = + let rec collect_locs locs {loc; sub; _} = List.fold_left collect_locs (loc :: locs) sub in let locs = collect_locs [] err in diff --git a/parsing/parser.mly b/parsing/parser.mly index e48236748..577595e34 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1266,7 +1266,7 @@ class_description: CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes { let (ext, attrs) = $2 in - Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs@$8) + Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8) ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) , ext } ; @@ -1426,7 +1426,7 @@ expr: | expr EQUAL expr { mkinfix $1 "=" $3 } | expr LESS expr - { mkinfix $1 "<" $3 } + { mkinfix $1 "<" $3 } | expr GREATER expr { mkinfix $1 ">" $3 } | expr OR expr diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 490bdc445..086e839de 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -218,7 +218,7 @@ class printer ()= object(self:'self) pp f "[%a] " (* space *) (self#list self#type_param ~sep:",") l - method type_with_label f (label,({ptyp_desc;_}as c) ) = + method type_with_label f (label, c) = match label with | Nolabel -> self#core_type1 f c (* otherwise parenthesize *) | Labelled s -> pp f "%s:%a" s self#core_type1 c @@ -330,7 +330,7 @@ class printer ()= object(self:'self) else match x.ppat_desc with | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]" self#pattern p protect_ident s.txt (* RA*) - | Ppat_or (p1, p2) -> (* *) + | Ppat_or _ -> (* *) pp f "@[%a@]" (self#list ~sep:"@,|" self#pattern) (list_of_pattern [] x) | _ -> self#pattern1 f x diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml index 47c370d89..e97d8e593 100644 --- a/toplevel/expunge.ml +++ b/toplevel/expunge.ml @@ -41,7 +41,7 @@ let expunge_map tbl = Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl let expunge_crcs tbl = - List.filter (fun (unit, crc) -> keep unit) tbl + List.filter (fun (unit, _crc) -> keep unit) tbl let main () = let input_name = Sys.argv.(1) in diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index dc7c8d88d..2c9d8a0cb 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -77,7 +77,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let hash x = try Hashtbl.hash x - with exn -> 0 + with _exn -> 0 end) @@ -159,7 +159,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let install_printer path ty fn = let print_val ppf obj = - try fn ppf obj with exn -> exn_printer ppf path in + try fn ppf obj with _exn -> exn_printer ppf path in let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in printers := (path, Simple (ty, printer)) :: !printers @@ -196,9 +196,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let tree_of_qualified lookup_fun env ty_path name = match ty_path with - | Pident id -> + | Pident _ -> Oide_ident name - | Pdot(p, s, pos) -> + | Pdot(p, _s, _pos) -> if try match (lookup_fun (Lident name) env).desc with | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' @@ -206,7 +206,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct with Not_found -> false then Oide_ident name else Oide_dot (Printtyp.tree_of_path p, name) - | Papply(p1, p2) -> + | Papply _ -> Printtyp.tree_of_path ty_path let tree_of_constr = @@ -255,7 +255,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct match (Ctype.repr ty).desc with | Tvar _ | Tunivar _ -> Oval_stuff "" - | Tarrow(_, ty1, ty2, _) -> + | Tarrow _ -> Oval_stuff "" | Ttuple(ty_list) -> Oval_tuple (tree_of_val_list 0 depth obj ty_list) @@ -545,15 +545,15 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct and find_printer depth env ty = let rec find = function | [] -> raise Not_found - | (name, Simple (sch, printer)) :: remainder -> + | (_name, Simple (sch, printer)) :: remainder -> if Ctype.moregeneral env false sch ty then printer else find remainder - | (name, Generic (path, fn)) :: remainder -> + | (_name, Generic (path, fn)) :: remainder -> begin match (Ctype.expand_head env ty).desc with | Tconstr (p, args, _) when Path.same p path -> begin try apply_generic_printer path (fn depth) args - with _ -> (fun obj -> out_exn path) end + with _ -> (fun _obj -> out_exn path) end | _ -> find remainder end in find !printers @@ -564,7 +564,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let printer = fn (fun depth obj -> tree_of_val depth obj arg) in apply_generic_printer path printer args | _ -> - (fun obj -> + (fun _obj -> let printer ppf = fprintf ppf "" Printtyp.path path in diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index cb155ff01..fe3119cec 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -151,7 +151,7 @@ let dir_install_printer ppf lid = let v = eval_path !toplevel_env path in let print_function = if is_old_style then - (fun formatter repr -> Obj.obj v (Obj.obj repr)) + (fun _formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in install_printer path ty_arg print_function @@ -159,7 +159,7 @@ let dir_install_printer ppf lid = let dir_remove_printer ppf lid = try - let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in begin try remove_printer path with Not_found -> diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 6d6b5beb0..4fa08dfca 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -99,9 +99,9 @@ let rec eval_path = function if Ident.persistent id || Ident.global id then global_symbol id else toplevel_value id - | Pdot(p, s, pos) -> + | Pdot(p, _s, pos) -> Obj.field (eval_path p) pos - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Toploop.eval_path" let eval_path env path = @@ -318,7 +318,7 @@ let execute_phrase print_outcome ppf phr = let res = load_lambda ppf ~module_ident res size in let out_phr = match res with - | Result v -> + | Result _ -> if Config.flambda then (* CR-someday trefis: *) () @@ -380,7 +380,7 @@ let execute_phrase print_outcome ppf phr = dir_name; false end - | Directive_int f, Pdir_int (n, Some _) -> + | Directive_int _, Pdir_int (_, Some _) -> fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name; false diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 6bd79611a..ab68d0164 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -73,42 +73,53 @@ module Options = Main_args.Make_opttop_options (struct let _noinit = set noinit let _clambda_checks () = clambda_checks := true let _inline spec = - Float_arg_helper.parse spec ~update:inline_threshold - ~help_text:"Syntax: -inline | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline | =[,...]" + inline_threshold let _inline_indirect_cost spec = - Int_arg_helper.parse spec ~update:inline_indirect_cost - ~help_text:"Syntax: -inline-indirect-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-indirect-cost | =[,...]" + inline_indirect_cost let _inline_toplevel spec = - Int_arg_helper.parse spec ~update:inline_toplevel_threshold - ~help_text:"Syntax: -inline-toplevel | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-toplevel | =[,...]" + inline_toplevel_threshold let _inlining_report () = inlining_report := true let _dump_pass pass = set_dumped_pass pass true let _rounds n = simplify_rounds := Some n let _inline_max_unroll spec = - Int_arg_helper.parse spec ~update:inline_max_unroll - ~help_text:"Syntax: -inline-max-unroll | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-unroll | =[,...]" + inline_max_unroll let _classic_inlining () = classic_inlining := true let _inline_call_cost spec = - Int_arg_helper.parse spec ~update:inline_call_cost - ~help_text:"Syntax: -inline-call-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-call-cost | =[,...]" + inline_call_cost let _inline_alloc_cost spec = - Int_arg_helper.parse spec ~update:inline_alloc_cost - ~help_text:"Syntax: -inline-alloc-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-alloc-cost | =[,...]" + inline_alloc_cost let _inline_prim_cost spec = - Int_arg_helper.parse spec ~update:inline_prim_cost - ~help_text:"Syntax: -inline-prim-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-prim-cost | =[,...]" + inline_prim_cost let _inline_branch_cost spec = - Int_arg_helper.parse spec ~update:inline_branch_cost - ~help_text:"Syntax: -inline-branch-cost | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-branch-cost | =[,...]" + inline_branch_cost let _inline_lifting_benefit spec = - Int_arg_helper.parse spec ~update:inline_lifting_benefit - ~help_text:"Syntax: -inline-lifting-benefit | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-lifting-benefit | =[,...]" + inline_lifting_benefit let _inline_branch_factor spec = - Float_arg_helper.parse spec ~update:inline_branch_factor - ~help_text:"Syntax: -inline-branch-factor | =[,...]" + Float_arg_helper.parse spec + "Syntax: -inline-branch-factor | =[,...]" + inline_branch_factor let _inline_max_depth spec = - Int_arg_helper.parse spec ~update:inline_max_depth - ~help_text:"Syntax: -inline-max-depth | =[,...]" + Int_arg_helper.parse spec + "Syntax: -inline-max-depth | =[,...]" + inline_max_depth let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures let _no_unbox_specialised_args = clear unbox_specialised_args let _o s = output_name := Some s diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 7cce1987c..b9c25692f 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -289,7 +289,7 @@ let printer_type ppf typename = raise Exit in printer_type -let match_simple_printer_type ppf desc printer_type = +let match_simple_printer_type desc printer_type = Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify !toplevel_env @@ -299,7 +299,7 @@ let match_simple_printer_type ppf desc printer_type = Ctype.generalize ty_arg; (ty_arg, None) -let match_generic_printer_type ppf desc path args printer_type = +let match_generic_printer_type desc path args printer_type = Ctype.begin_def(); let args = List.map (fun _ -> Ctype.newvar ()) args in let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in @@ -324,15 +324,15 @@ let match_printer_type ppf desc = let printer_type_old = printer_type ppf "printer_type_old" in Ctype.init_def(Ident.current_time()); try - (match_simple_printer_type ppf desc printer_type_new, false) + (match_simple_printer_type desc printer_type_new, false) with Ctype.Unify _ -> try - (match_simple_printer_type ppf desc printer_type_old, true) + (match_simple_printer_type desc printer_type_old, true) with Ctype.Unify _ as exn -> match extract_target_parameters desc.val_type with | None -> raise exn | Some (path, args) -> - (match_generic_printer_type ppf desc path args printer_type_new, + (match_generic_printer_type desc path args printer_type_new, false) let find_printer_type ppf lid = @@ -358,7 +358,7 @@ let dir_install_printer ppf lid = | None -> let print_function = if is_old_style then - (fun formatter repr -> Obj.obj v (Obj.obj repr)) + (fun _formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in install_printer path ty_arg print_function @@ -367,7 +367,7 @@ let dir_install_printer ppf lid = | [] -> let print_function = if is_old_style then - (fun formatter repr -> Obj.obj v (Obj.obj repr)) + (fun _formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in Zero print_function @@ -379,7 +379,7 @@ let dir_install_printer ppf lid = let dir_remove_printer ppf lid = try - let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in begin try remove_printer path with Not_found -> @@ -414,7 +414,7 @@ let dir_trace ppf lid = let (path, desc) = Env.lookup_value lid !toplevel_env in (* Check if this is a primitive *) match desc.val_kind with - | Val_prim p -> + | Val_prim _ -> fprintf ppf "%a is an external function and cannot be traced.@." Printtyp.longident lid | _ -> @@ -449,7 +449,7 @@ let dir_trace ppf lid = let dir_untrace ppf lid = try - let (path, desc) = Env.lookup_value lid !toplevel_env in + let (path, _desc) = Env.lookup_value lid !toplevel_env in let rec remove = function | [] -> fprintf ppf "%a was not traced.@." Printtyp.longident lid; @@ -530,7 +530,7 @@ let reg_show_prim name to_sig doc = let () = reg_show_prim "show_val" (fun env loc id lid -> - let path, desc = Typetexp.find_value env loc lid in + let _path, desc = Typetexp.find_value env loc lid in [ Sig_value (id, desc) ] ) "Print the signature of the corresponding value." @@ -538,7 +538,7 @@ let () = let () = reg_show_prim "show_type" (fun env loc id lid -> - let path, desc = Typetexp.find_type env loc lid in + let _path, desc = Typetexp.find_type env loc lid in [ Sig_type (id, desc, Trec_not) ] ) "Print the signature of the corresponding type constructor." @@ -569,7 +569,7 @@ let () = let () = reg_show_prim "show_module" (fun env loc id lid -> - let path, md = Typetexp.find_module env loc lid in + let _path, md = Typetexp.find_module env loc lid in [ Sig_module (id, {md with md_type = trim_signature md.md_type}, Trec_not) ] ) @@ -578,7 +578,7 @@ let () = let () = reg_show_prim "show_module_type" (fun env loc id lid -> - let path, desc = Typetexp.find_modtype env loc lid in + let _path, desc = Typetexp.find_modtype env loc lid in [ Sig_modtype (id, desc) ] ) "Print the signature of the corresponding module type." @@ -586,7 +586,7 @@ let () = let () = reg_show_prim "show_class" (fun env loc id lid -> - let path, desc = Typetexp.find_class env loc lid in + let _path, desc = Typetexp.find_class env loc lid in [ Sig_class (id, desc, Trec_not) ] ) "Print the signature of the corresponding class." @@ -594,7 +594,7 @@ let () = let () = reg_show_prim "show_class_type" (fun env loc id lid -> - let path, desc = Typetexp.find_class_type env loc lid in + let _path, desc = Typetexp.find_class_type env loc lid in [ Sig_class_type (id, desc, Trec_not) ] ) "Print the signature of the corresponding class type." @@ -740,9 +740,9 @@ let print_directive ppf (name, directive, doc) = | Directive_bool _ -> " " | Directive_ident _ -> " " in match doc with - | None -> printf "#%s%s@." name param + | None -> fprintf ppf "#%s%s@." name param | Some doc -> - printf "@[#%s%s@\n%a@]@." + fprintf ppf "@[#%s%s@\n%a@]@." name param Format.pp_print_text doc diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 445eddd47..eaf2a537b 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -65,9 +65,9 @@ let rec eval_path = function with Not_found -> raise (Symtable.Error(Symtable.Undefined_global name)) end - | Pdot(p, s, pos) -> + | Pdot(p, _s, pos) -> Obj.field (eval_path p) pos - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Toploop.eval_path" let eval_path env path = @@ -334,7 +334,7 @@ let execute_phrase print_outcome ppf phr = dir_name; false end - | Directive_int f, Pdir_int (n, Some _) -> + | Directive_int _, Pdir_int (_, Some _) -> fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name; false diff --git a/toplevel/trace.ml b/toplevel/trace.ml index fbc034276..cc732a61a 100644 --- a/toplevel/trace.ml +++ b/toplevel/trace.ml @@ -67,7 +67,7 @@ let rec instrument_result env name ppf clos_typ = match name with | Lident s -> Lident(s ^ "*") | Ldot(lid, s) -> Ldot(lid, s ^ "*") - | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in + | Lapply _ -> fatal_error "Trace.instrument_result" in let trace_res = instrument_result env starred_name ppf t2 in (fun clos_val -> Obj.repr (fun arg -> diff --git a/typing/btype.ml b/typing/btype.ml index 69c936470..0c9903a0d 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -383,7 +383,7 @@ let type_iterators = | Tvariant row -> may (fun (p,_) -> it.it_path p) (row_repr row).row_name | _ -> () - and it_path p = () + and it_path _p = () in { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; it_type_kind; it_class_type; it_module_type; @@ -436,12 +436,12 @@ let rec copy_type_desc ?(keep_names=false) f = function | Tobject(ty, {contents = Some (p, tl)}) -> Tobject (f ty, ref (Some(p, List.map f tl))) | Tobject (ty, _) -> Tobject (f ty, ref None) - | Tvariant row -> assert false (* too ambiguous *) + | Tvariant _ -> assert false (* too ambiguous *) | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) Tfield (p, field_kind_repr k, f ty1, f ty2) | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc - | Tsubst ty -> assert false + | Tsubst _ -> assert false | Tunivar _ as ty -> ty (* always keep the name *) | Tpoly (ty, tyl) -> let tyl = List.map (fun x -> norm_univar (f x)) tyl in @@ -510,7 +510,7 @@ let rec unmark_type ty = end let unmark_iterators = - let it_type_expr it ty = unmark_type ty in + let it_type_expr _it ty = unmark_type ty in {type_iterators with it_type_expr} let unmark_type_decl decl = @@ -523,7 +523,7 @@ let unmark_extension_constructor ext = let unmark_class_signature sign = unmark_type sign.csig_self; - Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars let unmark_class_type cty = unmark_iterators.it_class_type unmark_iterators cty @@ -542,7 +542,7 @@ let lte_public p1 p2 = (* Private <= Public *) let rec find_expans priv p1 = function Mnil -> None - | Mcons (priv', p2, ty0, ty, _) + | Mcons (priv', p2, _ty0, ty, _) when lte_public priv priv' && Path.same p1 p2 -> Some ty | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem | Mlink {contents = rem} -> find_expans priv p1 rem @@ -718,7 +718,7 @@ let rec rev_compress_log log r = | Change (_, next) -> rev_compress_log log next -let undo_compress (changes, old) = +let undo_compress (changes, _old) = match !changes with Unchanged | Invalid -> () diff --git a/typing/ctype.ml b/typing/ctype.ml index aca755c91..bb7758c99 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -284,9 +284,9 @@ let associate_fields fields1 fields2 = (List.rev p, List.rev s, (List.rev s') @ l') | ((n, k, t)::r, (n', k', t')::r') when n = n' -> associate ((n, k, t, k', t')::p) s s' (r, r') - | ((n, k, t)::r, ((n', k', t')::_ as l')) when n < n' -> + | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' -> associate p ((n, k, t)::s) s' (r, l') - | (((n, k, t)::r as l), (n', k', t')::r') (* when n > n' *) -> + | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) -> associate p s ((n', k', t')::s') (l, r') in associate [] [] [] (fields1, fields2) @@ -345,7 +345,7 @@ let row_variable ty = let set_object_name id rv params ty = match (repr ty).desc with - Tobject (fi, nm) -> + Tobject (_fi, nm) -> set_name nm (Some (Path.Pident id, rv::params)) | _ -> assert false @@ -382,7 +382,7 @@ let rec signature_of_class_type = function Cty_constr (_, _, cty) -> signature_of_class_type cty | Cty_signature sign -> sign - | Cty_arrow (_, ty, cty) -> signature_of_class_type cty + | Cty_arrow (_, _, cty) -> signature_of_class_type cty let self_type cty = repr (signature_of_class_type cty).csig_self @@ -418,7 +418,7 @@ let merge_row_fields fi1 fi2 = let rec filter_row_fields erase = function [] -> [] - | (l,f as p)::fi -> + | (_l,f as p)::fi -> let fi = filter_row_fields erase fi in match row_field_repr f with Rabsent -> fi @@ -511,7 +511,7 @@ let closed_type_decl decl = | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l ) v - | Type_record(r, rep) -> + | Type_record(r, _rep) -> List.iter (fun l -> closed_type l.ld_type) r | Type_open -> () end; @@ -659,7 +659,7 @@ let rec generalize_spine ty = | _ -> () let forward_try_expand_once = (* Forward declaration *) - ref (fun env ty -> raise Cannot_expand) + ref (fun _env _ty -> raise Cannot_expand) (* Lower the levels of a type (assume [level] is not @@ -707,7 +707,7 @@ let rec update_level env level ty = | None -> () end; match ty.desc with - Tconstr(p, tl, abbrev) when level < get_level env p -> + Tconstr(p, _tl, _abbrev) when level < get_level env p -> (* Try first to replace an abbreviation by its expansion. *) begin try (* if is_newtype env p then raise Cannot_expand; *) @@ -724,14 +724,14 @@ let rec update_level env level ty = if Path.same p p' then raise (Unify [(ty, newvar2 level)]); log_type ty; ty.desc <- Tpackage (p', nl, tl); update_level env level ty - | Tobject(_, ({contents=Some(p, tl)} as nm)) + | Tobject(_, ({contents=Some(p, _tl)} as nm)) when level < get_level env p -> set_name nm None; update_level env level ty | Tvariant row -> let row = row_repr row in begin match row.row_name with - | Some (p, tl) when level < get_level env p -> + | Some (p, _tl) when level < get_level env p -> log_type ty; ty.desc <- Tvariant {row with row_name = None} | _ -> () @@ -864,7 +864,7 @@ let compute_univars ty = let node_univars = TypeHash.create 17 in let rec add_univar univ inv = match inv.inv_type.desc with - Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> () + Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () | _ -> try let univs = TypeHash.find node_univars inv.inv_type in @@ -1025,7 +1025,7 @@ let rec copy ?env ?partial ?keep_names ty = (* Return a new copy *) Tvariant (copy_row copy true row keep more') end - | Tfield (p, k, ty1, ty2) -> + | Tfield (_p, k, _ty1, ty2) -> begin match field_kind_repr k with Fabsent -> Tlink (copy ty2) | Fpresent -> copy_type_desc copy desc @@ -1064,7 +1064,7 @@ let instance_def sch = cleanup_types (); ty -let generic_instance ?partial env sch = +let generic_instance env sch = let old = !current_level in current_level := generic_level; let ty = instance env sch in @@ -1281,7 +1281,7 @@ let instance_label fixed lbl = match repr lbl.lbl_arg with {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty - | ty -> + | _ -> [], copy lbl.lbl_arg in cleanup_types (); @@ -1290,7 +1290,7 @@ let instance_label fixed lbl = (**** Instantiation with parameter substitution ****) let unify' = (* Forward declaration *) - ref (fun env ty1 ty2 -> raise (Unify [])) + ref (fun _env _ty1 _ty2 -> raise (Unify [])) let subst env level priv abbrev ty params args body = if List.length params <> List.length args then raise (Unify []); @@ -1439,7 +1439,7 @@ let safe_abbrev env ty = let try_expand_once env ty = let ty = repr ty in match ty.desc with - Tconstr (p, _, _) -> repr (expand_abbrev env ty) + Tconstr _ -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand (* This one only raises Cannot_expand *) @@ -1524,7 +1524,7 @@ let expand_head_opt env ty = respect the type constraints *) let enforce_constraints env ty = match ty with - {desc = Tconstr (path, args, abbrev); level = level} -> + {desc = Tconstr (path, args, _abbrev); level = level} -> begin try let decl = Env.find_type path env in ignore @@ -1588,7 +1588,7 @@ let rec occur_rec env allow_recursive visited ty0 = function | ty -> if ty == ty0 then raise Occur; match ty.desc with - Tconstr(p, tl, abbrev) -> + Tconstr(p, _tl, _abbrev) -> if allow_recursive && is_contractive env p then () else begin try if TypeSet.mem ty visited then raise Occur; @@ -1639,7 +1639,7 @@ let rec local_non_recursive_abbrev visited env p ty = let ty = repr ty in if not (List.memq ty visited) then begin match ty.desc with - Tconstr(p', args, abbrev) -> + Tconstr(p', args, _abbrev) -> if Path.same p p' then raise Occur; if is_contractive env p' then () else let visited = ty :: visited in @@ -2034,7 +2034,7 @@ and mcomp_fields type_pairs env ty1 ty2 = if miss1 <> [] && (object_row ty1).desc = Tnil || miss2 <> [] && (object_row ty2).desc = Tnil then raise (Unify []); List.iter - (function (n, k1, t1, k2, t2) -> + (function (_n, k1, t1, k2, t2) -> mcomp_kind k1 k2; mcomp type_pairs env t1 t2) pairs @@ -2244,7 +2244,7 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found -let unify_eq env t1 t2 = +let unify_eq t1 t2 = t1 == t2 || match !umode with | Expression -> false @@ -2269,7 +2269,7 @@ let rec unify (env:Env.t ref) t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in - if unify_eq !env t1 t2 then () else + if unify_eq t1 t2 then () else let reset_tracing = check_trace_gadt_instances !env in try @@ -2326,7 +2326,7 @@ and unify2 env t1 t2 = let lv = min t1'.level t2'.level in update_level !env lv t2; update_level !env lv t1; - if unify_eq !env t1' t2' then () else + if unify_eq t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in if !trace_gadt_instances then begin @@ -2346,7 +2346,7 @@ and unify2 env t1 t2 = (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2) else (t1, t2) in - if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then + if unify_eq t1 t1' || not (unify_eq t2 t2') then unify3 env t1 t1' t2 t2' else try unify3 env t2 t2' t1 t1' with Unify trace -> @@ -2568,7 +2568,7 @@ and unify_kind k1 k2 = 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 unify_eq !env rm1 rm2 then () else + if unify_eq rm1 rm2 then () else let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if r1 <> [] && r2 <> [] then begin let ht = Hashtbl.create (List.length r1) in @@ -2683,7 +2683,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = and (tl2',tlu2) = split_univars tl2' in begin match tlu1, tlu2 with [], [] -> () - | (tu1::tlu1), (tu2::_) -> + | (tu1::tlu1), _ :: _ -> (* Attempt to merge all the types containing univars *) List.iter (unify env tu1) (tlu1@tlu2) | (tu::_, []) | ([], tu::_) -> occur_univar !env tu @@ -2934,7 +2934,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = end | (Tvariant row1, Tvariant row2) -> moregen_row inst_nongen type_pairs env row1 row2 - | (Tobject (fi1, nm1), Tobject (fi2, nm2)) -> + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> moregen_fields inst_nongen type_pairs env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) moregen_fields inst_nongen type_pairs env t1' t2' @@ -3011,7 +3011,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = | _ -> raise (Unify []) end; List.iter - (fun (l,f1,f2) -> + (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 @@ -3200,7 +3200,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = end | (Tvariant row1, Tvariant row2) -> eqtype_row rename type_pairs subst env row1 row2 - | (Tobject (fi1, nm1), Tobject (fi2, nm2)) -> + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> eqtype_fields rename type_pairs subst env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) eqtype_fields rename type_pairs subst env t1' t2' @@ -3349,19 +3349,19 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.csig_self) in let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let (fields1, _rest1) = flatten_fields ty1 + and (fields2, _rest2) = flatten_fields ty2 in + let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in List.iter - (fun (lab, k1, t1, k2, t2) -> + (fun (lab, _k1, t1, _k2, t2) -> begin try moregen true type_pairs env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch (lab, env, expand_trace env trace)]) end) pairs; Vars.iter - (fun lab (mut, v, ty) -> - let (mut', v', ty') = Vars.find lab sign1.csig_vars in + (fun lab (_mut, _v, ty) -> + let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, env, expand_trace env trace)])) @@ -3418,16 +3418,16 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = moregen true type_pairs env rest1 rest2; let error = List.fold_right - (fun (lab, k1, t1, k2, t2) err -> + (fun (lab, k1, _t1, k2, _t2) err -> try moregen_kind k1 k2; err with Unify _ -> CM_Public_method lab::err) pairs error in let error = Vars.fold - (fun lab (mut, vr, ty) err -> + (fun lab (mut, vr, _ty) err -> try - let (mut', vr', ty') = Vars.find lab sign1.csig_vars in + let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then @@ -3484,11 +3484,11 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.csig_self) in let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let (fields1, _rest1) = flatten_fields ty1 + and (fields2, _rest2) = flatten_fields ty2 in + let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in List.iter - (fun (lab, k1, t1, k2, t2) -> + (fun (lab, _k1, t1, _k2, t2) -> begin try eqtype true type_pairs subst env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch @@ -3527,7 +3527,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = let err = let k = field_kind_repr k in begin match k with - Fvar r -> err + Fvar _ -> err | _ -> CM_Hide_public lab::err end in @@ -3543,7 +3543,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = eqtype true type_pairs subst env rest1 rest2; let error = List.fold_right - (fun (lab, k1, t1, k2, t2) err -> + (fun (lab, k1, _t1, k2, _t2) err -> let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with @@ -3556,9 +3556,9 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = in let error = Vars.fold - (fun lab (mut, vr, ty) err -> + (fun lab (mut, vr, _ty) err -> try - let (mut', vr', ty') = Vars.find lab sign1.csig_vars in + let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then @@ -3651,7 +3651,7 @@ let rec lid_of_path ?(sharp="") = function Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2) let find_cltype_for_path env p = - let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in + let _path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in match cl_abbr.type_manifest with Some ty -> begin match (repr ty).desc with @@ -3733,7 +3733,7 @@ let rec build_subtype env visited loops posi level t = if c > Unchanged then (t'',c) else (t, Unchanged) end - | Tconstr(p, tl, abbrev) -> + | Tconstr(p, tl, _abbrev) -> (* Must check recursion on constructors, since we do not always expand them *) if memq_warn t visited then (t, Unchanged) else @@ -3872,10 +3872,10 @@ let rec subtype_rec env trace t1 t2 cstrs = subtype_list env trace tl1 tl2 cstrs | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> cstrs - | (Tconstr(p1, tl1, abbrev1), _) + | (Tconstr(p1, _tl1, _abbrev1), _) when generic_abbrev env p1 && safe_abbrev env t1 -> subtype_rec env trace (expand_abbrev env t1) t2 cstrs - | (_, Tconstr(p2, tl2, abbrev2)) + | (_, Tconstr(p2, _tl2, _abbrev2)) when generic_abbrev env p2 && safe_abbrev env t2 -> subtype_rec env trace t1 (expand_abbrev env t2) cstrs | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> @@ -3979,7 +3979,7 @@ and subtype_fields env trace ty1 ty2 cstrs = !univar_pairs) :: cstrs in List.fold_left - (fun cstrs (_, k1, t1, k2, t2) -> + (fun cstrs (_, _k1, t1, _k2, t2) -> (* Theses fields are always present *) subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) cstrs pairs @@ -4078,7 +4078,7 @@ let unalias 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. *) @@ -4086,7 +4086,7 @@ let cyclic_abbrev env id ty = let rec check_cycle seen ty = let ty = repr ty in match ty.desc with - Tconstr (p, tl, abbrev) -> + Tconstr (p, _tl, _abbrev) -> p = Path.Pident id || List.memq ty seen || begin try check_cycle (ty :: seen) (expand_abbrev_opt env ty) @@ -4221,7 +4221,7 @@ let rec nondep_type_rec env id ty = TypeHash.add nondep_hash ty ty'; ty'.desc <- begin match ty.desc with - | Tconstr(p, tl, abbrev) -> + | Tconstr(p, tl, _abbrev) -> if Path.isfree id p then begin try Tlink (nondep_type_rec env id @@ -4266,7 +4266,7 @@ let rec nondep_type_rec env id ty = let row = copy_row (nondep_type_rec env id) true row true more' in match row.row_name with - Some (p, tl) when Path.isfree id p -> + Some (p, _tl) when Path.isfree id p -> Tvariant {row with row_name = None} | _ -> Tvariant row end @@ -4432,7 +4432,7 @@ let rec collapse_conj env visited ty = Tvariant row -> let row = row_repr row in List.iter - (fun (l,fi) -> + (fun (_l,fi) -> match row_field_repr fi with Reither (c, t1::(_::_ as tl), m, e) -> List.iter (unify env t1) tl; @@ -4459,7 +4459,7 @@ let () = let maybe_pointer_type env typ = match (repr typ).desc with - | Tconstr(p, args, abbrev) -> + | Tconstr(p, _args, _abbrev) -> begin try let type_decl = Env.find_type p env in not type_decl.type_immediate diff --git a/typing/ctype.mli b/typing/ctype.mli index 6da7fa867..e9b2b24c0 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -116,7 +116,7 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr partial=true -> newty2 ty.level Tvar for non generic subterms *) val instance_def: type_expr -> type_expr (* use defaults *) -val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr +val generic_instance: Env.t -> type_expr -> type_expr (* Same as instance, but new nodes at generic_level *) val instance_list: Env.t -> type_expr list -> type_expr list (* Take an instance of a list of type schemes *) diff --git a/typing/env.ml b/typing/env.ml index 20e7a7ce2..7b458329e 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -297,22 +297,22 @@ let diff env1 env2 = (* Forward declarations *) let components_of_module' = - ref ((fun ~deprecated env sub path mty -> assert false) : + ref ((fun ~deprecated:_ _env _sub _path _mty -> assert false) : deprecated:string option -> t -> Subst.t -> Path.t -> module_type -> module_components) let components_of_module_maker' = - ref ((fun (env, sub, path, mty) -> assert false) : + ref ((fun (_env, _sub, _path, _mty) -> assert false) : t * Subst.t * Path.t * module_type -> module_components_repr) let components_of_functor_appl' = - ref ((fun f env p1 p2 -> assert false) : + ref ((fun _f _env _p1 _p2 -> assert false) : functor_components -> t -> Path.t -> Path.t -> module_components) let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) - ref ((fun env mty1 path1 mty2 -> assert false) : + ref ((fun _env _mty1 _path1 _mty2 -> assert false) : t -> module_type -> Path.t -> module_type -> unit) let strengthen = (* to be filled with Mtype.strengthen *) - ref ((fun env mty path -> assert false) : + ref ((fun _env _mty _path -> assert false) : t -> module_type -> Path.t -> module_type) let md md_type = @@ -524,42 +524,42 @@ let rec find_module_descr path env = match path with Pident id -> begin try - let (p, desc) = EnvTbl.find_same id env.components + let (_p, desc) = EnvTbl.find_same id env.components in desc with Not_found -> if Ident.persistent id && not (Ident.name id = !current_unit) then (find_pers_struct (Ident.name id)).ps_comps else raise Not_found end - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> begin match get_components (find_module_descr p env) with Structure_comps c -> - let (descr, pos) = Tbl.find s c.comp_components in + let (descr, _pos) = Tbl.find s c.comp_components in descr - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end | Papply(p1, p2) -> begin match get_components (find_module_descr p1 env) with Functor_comps f -> !components_of_functor_appl' f env p1 p2 - | Structure_comps c -> + | Structure_comps _ -> raise Not_found end let find proj1 proj2 path env = match path with Pident id -> - let (p, data) = EnvTbl.find_same id (proj1 env) + let (_p, data) = EnvTbl.find_same id (proj1 env) in data - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> begin match get_components (find_module_descr p env) with Structure_comps c -> - let (data, pos) = Tbl.find s (proj2 c) in data - | Functor_comps f -> + let (data, _pos) = Tbl.find s (proj2 c) in data + | Functor_comps _ -> raise Not_found end - | Papply(p1, p2) -> + | Papply _ -> raise Not_found let find_value = @@ -627,7 +627,7 @@ let find_module ~alias path env = match path with Pident id -> begin try - let (p, data) = EnvTbl.find_same id env.modules + let (_p, data) = EnvTbl.find_same id env.modules in data with Not_found -> if Ident.persistent id && not (Ident.name id = !current_unit) then @@ -635,12 +635,12 @@ let find_module ~alias path env = md (Mty_signature(Lazy.force ps.ps_sig)) else raise Not_found end - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> begin match get_components (find_module_descr p env) with Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in + let (data, _pos) = Tbl.find s c.comp_modules in md (EnvLazy.force subst_modtype_maker data) - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end | Papply(p1, p2) -> @@ -648,7 +648,7 @@ let find_module ~alias path env = begin match get_components desc1 with Functor_comps f -> md begin match f.fcomp_res with - | Mty_alias p as mty-> mty + | Mty_alias _ as mty -> mty | mty -> if alias then mty else try @@ -661,7 +661,7 @@ let find_module ~alias path env = Hashtbl.add f.fcomp_subst_cache p2 mty; mty end - | Structure_comps c -> + | Structure_comps _ -> raise Not_found end @@ -754,7 +754,7 @@ let rec is_functor_arg path env = begin try Ident.find_same id env.functor_args; true with Not_found -> false end - | Pdot (p, s, _) -> is_functor_arg p env + | Pdot (p, _s, _) -> is_functor_arg p env | Papply _ -> true (* Lookup by name *) @@ -786,7 +786,7 @@ let rec lookup_module_descr_aux ?loc lid env = Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in (Pdot(p, s, pos), descr) - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end | Lapply(l1, l2) -> @@ -797,7 +797,7 @@ let rec lookup_module_descr_aux ?loc lid env = Functor_comps f -> Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; (Papply(p1, p2), !components_of_functor_appl' f env p1 p2) - | Structure_comps c -> + | Structure_comps _ -> raise Not_found end @@ -834,12 +834,12 @@ and lookup_module ~load ?loc lid env : Path.t = let (p, descr) = lookup_module_descr ?loc l env in begin match get_components descr with Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in + let (_data, pos) = Tbl.find s c.comp_modules in let (comps, _) = Tbl.find s c.comp_components in let p = Pdot(p, s, pos) in report_deprecated ?loc p comps.deprecated; p - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end | Lapply(l1, l2) -> @@ -851,7 +851,7 @@ and lookup_module ~load ?loc lid env : Path.t = Functor_comps f -> Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; p - | Structure_comps c -> + | Structure_comps _ -> raise Not_found end @@ -865,10 +865,10 @@ let lookup proj1 proj2 ?loc lid env = Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in (Pdot(p, s, pos), data) - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end - | Lapply(l1, l2) -> + | Lapply _ -> raise Not_found let lookup_all_simple proj1 proj2 shadow ?loc lid env = @@ -880,23 +880,23 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env = | [] -> [] | ((x, f) :: xs) -> (x, f) :: - (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs)) + (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs)) in do_shadow xl | Ldot(l, s) -> - let (p, desc) = lookup_module_descr ?loc l env in + let (_p, desc) = lookup_module_descr ?loc l env in begin match get_components desc with Structure_comps c -> let comps = try Tbl.find s (proj2 c) with Not_found -> [] in List.map - (fun (data, pos) -> (data, (fun () -> ()))) + (fun (data, _pos) -> (data, (fun () -> ()))) comps - | Functor_comps f -> + | Functor_comps _ -> raise Not_found end - | Lapply(l1, l2) -> + | Lapply _ -> raise Not_found let has_local_constraints env = env.local_constraints @@ -906,7 +906,7 @@ let cstr_shadow cstr1 cstr2 = | Cstr_extension _, Cstr_extension _ -> true | _ -> false -let lbl_shadow lbl1 lbl2 = false +let lbl_shadow _lbl1 _lbl2 = false let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) @@ -1098,7 +1098,7 @@ let iter_env proj1 proj2 f env () = let visit = match EnvLazy.get_arg mcomps.comps with | None -> true - | Some (env, sub, path, mty) -> scrape_alias_for_visit env mty + | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty in if not visit then () else match get_components mcomps with @@ -1257,35 +1257,35 @@ let rec prefix_idents root pos sub = function let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) - | Sig_type(id, decl, _) :: rem -> + | Sig_type(id, _, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Sig_typext(id, ext, _) :: rem -> + | Sig_typext(id, _, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in (* we extend the substitution in case of an inlined record *) let (pl, final_sub) = prefix_idents root (pos+1) (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Sig_module(id, mty, _) :: rem -> + | Sig_module(id, _, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) (Subst.add_module id p sub) rem in (p::pl, final_sub) - | Sig_modtype(id, decl) :: rem -> + | Sig_modtype(id, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_modtype id (Mty_ident p) sub) rem in (p::pl, final_sub) - | Sig_class(id, decl, _) :: rem -> + | Sig_class(id, _, _) :: rem -> (* pretend this is a type, cf. PR#6650 *) let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Sig_class_type(id, decl, _) :: rem -> + | Sig_class_type(id, _, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in @@ -1662,7 +1662,7 @@ let add_module ?arg id mty env = let add_local_constraint id info elv env = match info with - {type_manifest = Some ty; type_newtype_level = Some (lv, _)} -> + {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> (* elv is the expansion level, lv is the definition level *) let env = add_type ~check:false @@ -1711,7 +1711,7 @@ let rec add_signature sg env = let open_signature slot root sg env0 = (* First build the paths and substitution *) - let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in + let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in let sg = Lazy.force sg in (* Then enter the components in the environment after substitution *) @@ -1877,17 +1877,17 @@ let find_all_simple_list proj1 proj2 f lid env acc = match lid with | None -> EnvTbl.fold_name - (fun id data acc -> f data acc) + (fun _id data acc -> f data acc) (proj1 env) acc | Some l -> - let p, desc = lookup_module_descr l env in + let (_p, desc) = lookup_module_descr l env in begin match get_components desc with Structure_comps c -> Tbl.fold - (fun s comps acc -> + (fun _s comps acc -> match comps with [] -> acc - | (data, pos) :: _ -> + | (data, _pos) :: _ -> f data acc) (proj2 c) acc | Functor_comps _ -> diff --git a/typing/ident.mli b/typing/ident.mli index 1c9b6e047..52dd54ea5 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -17,6 +17,14 @@ type t = { stamp: int; name: string; mutable flags: int } +include Identifiable.S with type t := t +(* Notes: + - [equal] compares identifiers by name + - [compare x y] is 0 if [same x y] is true. + - [compare] compares identifiers by binding location +*) + + val create: string -> t val create_persistent: string -> t val create_predef_exn: string -> t @@ -25,8 +33,6 @@ val name: t -> string val unique_name: t -> string val unique_toplevel_name: t -> string val persistent: t -> bool -val equal: t -> t -> bool - (* Compare identifiers by name. *) val same: t -> t -> bool (* Compare identifiers by binding location. Two identifiers are the same either if they are both @@ -34,17 +40,12 @@ val same: t -> t -> bool [new], or if they are both persistent and have the same name. *) val compare: t -> t -> int - (* [compare x y] is 0 if [same x y] is true. *) -val hash: t -> int val hide: t -> t (* Return an identifier with same name as the given identifier, but stamp different from any stamp returned by new. When put in a 'a tbl, this identifier can only be looked up by name. *) -val compare : t -> t -> int -(* Compare identifiers by binding location *) - val make_global: t -> unit val global: t -> bool val is_predef_exn: t -> bool @@ -54,9 +55,6 @@ val current_time: unit -> int val set_current_time: int -> unit val reinit: unit -> unit -val print: Format.formatter -> t -> unit -val output : out_channel -> t -> unit - type 'a tbl (* Association tables from identifiers to type 'a. *) @@ -73,5 +71,3 @@ val iter: (t -> 'a -> unit) -> 'a tbl -> unit (* Idents for sharing keys *) val make_key_generator : unit -> (t -> t) - -include Identifiable.S with type t := t diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 92e06f1bf..10748bffd 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -47,7 +47,7 @@ let include_err ppf = function | CM_Virtual_class -> fprintf ppf "A class cannot be changed from virtual to concrete" - | CM_Parameter_arity_mismatch (ls, lp) -> + | CM_Parameter_arity_mismatch _ -> fprintf ppf "The classes do not have the same number of type parameters" | CM_Type_parameter_mismatch (env, trace) -> diff --git a/typing/includecore.ml b/typing/includecore.ml index a1bc3bdc5..c367640b7 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -33,7 +33,7 @@ let value_descriptions env vd1 vd2 = let pc = {pc_desc = p; pc_type = vd2.Types.val_type; pc_env = env; pc_loc = vd1.Types.val_loc; } in Tcoerce_primitive pc - | (_, Val_prim p) -> raise Dont_match + | (_, Val_prim _) -> raise Dont_match | (_, _) -> Tcoerce_none end else raise Dont_match @@ -51,7 +51,7 @@ let private_flags decl1 decl2 = let is_absrow env ty = match ty.desc with - Tconstr(Pident id, _, _) -> + Tconstr(Pident _, _, _) -> begin match Ctype.expand_head env ty with {desc=Tobject _|Tvariant _} -> true | _ -> false @@ -98,7 +98,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = Ctype.equal env true (ty1::params1) (rest2::params2) && let (fields1,rest1) = Ctype.flatten_fields fi1 in (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && - let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] && let tl1, tl2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in diff --git a/typing/includemod.ml b/typing/includemod.ml index 6f9b2eeb7..2a2ee1f78 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -245,11 +245,11 @@ and try_modtypes env cxt subst mty1 mty2 = Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2) | (Mty_ident p1, _) when may_expand_module_path env p1 -> try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 - | (_, Mty_ident p2) -> + | (_, Mty_ident _) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) | (Mty_signature sig1, Mty_signature sig2) -> signatures env cxt subst sig1 sig2 - | (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) -> + | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) -> begin match modtypes env (Body param1::cxt) subst res1 res2 with Tcoerce_none -> Tcoerce_none | cc -> Tcoerce_functor (Tcoerce_none, cc) @@ -372,34 +372,34 @@ and signature_components old_env env cxt subst paired = let comps_rec rem = signature_components old_env env cxt subst rem in match paired with [] -> [] - | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem -> + | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem -> let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with - Val_prim p -> comps_rec rem + Val_prim _ -> comps_rec rem | _ -> (pos, cc) :: comps_rec rem end - | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> + | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem -> type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2; comps_rec rem - | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos) + | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos) :: rem -> extension_constructors env cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: comps_rec rem - | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> + | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem -> let p1 = Pident id1 in let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1) mty2.md_type in (pos, cc) :: comps_rec rem - | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> + | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; comps_rec rem - | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem -> + | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem -> class_declarations ~old_env env cxt subst id1 decl1 decl2; (pos, Tcoerce_none) :: comps_rec rem | (Sig_class_type(id1, info1, _), - Sig_class_type(id2, info2, _), pos) :: rem -> + Sig_class_type(_id2, info2, _), _pos) :: rem -> class_type_declarations ~old_env env cxt subst id1 info1 info2; comps_rec rem | _ -> @@ -413,7 +413,7 @@ and modtype_infos env cxt subst id info1 info2 = try match (info1.mtd_type, info2.mtd_type) with (None, None) -> () - | (Some mty1, None) -> () + | (Some _, None) -> () | (Some mty1, Some mty2) -> check_modtype_equiv env cxt' mty1 mty2 | (None, Some mty2) -> @@ -427,9 +427,9 @@ and check_modtype_equiv env cxt mty1 mty2 = modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (c1, c2) -> + | (_c1, _c2) -> (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." - print_coercion c1 print_coercion c2; *) + print_coercion _c1 print_coercion _c2; *) raise(Error [cxt, env, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) @@ -438,7 +438,7 @@ let check_modtype_inclusion env mty1 path1 mty2 = try ignore(modtypes env [] Subst.identity (Mtype.strengthen env mty1 path1) mty2) - with Error reasons -> + with Error _ -> raise Not_found let _ = Env.check_modtype_inclusion := check_modtype_inclusion diff --git a/typing/mtype.ml b/typing/mtype.ml index c1995dc3b..7cb0d621d 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -46,10 +46,10 @@ let rec strengthen env mty p = and strengthen_sig env sg p pos = match sg with [] -> [] - | (Sig_value(id, desc) as sigelt) :: rem -> + | (Sig_value(_, desc) as sigelt) :: rem -> let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in sigelt :: strengthen_sig env rem p nextpos - | Sig_type(id, {type_kind=Type_abstract}, rs) :: + | Sig_type(id, {type_kind=Type_abstract}, _) :: (Sig_type(id', {type_private=Private}, _) :: _ as rem) when Ident.name id = Ident.name id' ^ "#row" -> strengthen_sig env rem p pos @@ -68,7 +68,7 @@ and strengthen_sig env sg p pos = { decl with type_manifest = manif } in Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos - | (Sig_typext(id, ext, es) as sigelt) :: rem -> + | (Sig_typext _ as sigelt) :: rem -> sigelt :: strengthen_sig env rem p (pos+1) | Sig_module(id, md, rs) :: rem -> let str = @@ -91,9 +91,9 @@ and strengthen_sig env sg p pos = Sig_modtype(id, newdecl) :: strengthen_sig (Env.add_modtype id decl env) rem p pos (* Need to add the module type in case it is manifest *) - | (Sig_class(id, decl, rs) as sigelt) :: rem -> + | (Sig_class _ as sigelt) :: rem -> sigelt :: strengthen_sig env rem p (pos+1) - | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> + | (Sig_class_type _ as sigelt) :: rem -> sigelt :: strengthen_sig env rem p pos and strengthen_decl env md p = @@ -171,7 +171,7 @@ let nondep_supertype env mid mty = let enrich_typedecl env p decl = match decl.type_manifest with - Some ty -> decl + Some _ -> decl | None -> try let orig_decl = Env.find_type p env in @@ -203,18 +203,18 @@ and enrich_item env p = function let rec type_paths env p mty = match scrape env mty with - Mty_ident p -> [] - | Mty_alias p -> [] + Mty_ident _ -> [] + | Mty_alias _ -> [] | Mty_signature sg -> type_paths_sig env p 0 sg - | Mty_functor(param, arg, res) -> [] + | Mty_functor _ -> [] and type_paths_sig env p pos sg = match sg with [] -> [] - | Sig_value(id, decl) :: rem -> + | Sig_value(_id, decl) :: rem -> let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in type_paths_sig env p pos' rem - | Sig_type(id, decl, _) :: rem -> + | Sig_type(id, _decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem | Sig_module(id, md, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @ @@ -228,15 +228,15 @@ and type_paths_sig env p pos sg = let rec no_code_needed env mty = match scrape env mty with - Mty_ident p -> false + Mty_ident _ -> false | Mty_signature sg -> no_code_needed_sig env sg | Mty_functor(_, _, _) -> false - | Mty_alias p -> true + | Mty_alias _ -> true and no_code_needed_sig env sg = match sg with [] -> true - | Sig_value(id, decl) :: rem -> + | Sig_value(_id, decl) :: rem -> begin match decl.val_kind with | Val_prim _ -> no_code_needed_sig env rem | _ -> false @@ -246,7 +246,7 @@ and no_code_needed_sig env sg = no_code_needed_sig (Env.add_module_declaration id md env) rem | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem - | (Sig_typext _ | Sig_class _) :: rem -> + | (Sig_typext _ | Sig_class _) :: _ -> false diff --git a/typing/oprint.ml b/typing/oprint.ml index 5860c6028..65db0f118 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -431,7 +431,7 @@ and print_out_sig_item ppf = | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) - | Osig_typext (ext, es) -> + | Osig_typext (ext, _es) -> print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> fprintf ppf "@[<2>module type %s@]" name diff --git a/typing/parmatch.ml b/typing/parmatch.ml index cc2a780f4..dfeaf94a1 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -93,9 +93,9 @@ let rec compat p q = | Tpat_lazy p, Tpat_lazy q -> compat p q | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 - | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> + | Tpat_variant(l1,Some p1, _r1), Tpat_variant(l2,Some p2,_) -> l1=l2 && compat p1 p2 - | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) -> + | Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) -> l1 = l2 | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false @@ -156,7 +156,7 @@ let rec pretty_val ppf v = begin match cstr with | Tpat_unpack -> fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_constraint ctyp -> + | Tpat_constraint _ -> fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } | Tpat_type _ -> fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } @@ -323,8 +323,8 @@ let all_record_args lbls = match lbls with (* Build argument list when p2 >= p1, where p1 is a simple pattern *) let rec simple_match_args p1 p2 = match p2.pat_desc with | Tpat_alias (p2,_,_) -> simple_match_args p1 p2 -| Tpat_construct(_, cstr, args) -> args -| Tpat_variant(lab, Some arg, _) -> [arg] +| Tpat_construct(_, _, args) -> args +| Tpat_variant(_, Some arg, _) -> [arg] | Tpat_tuple(args) -> args | Tpat_record(args,_) -> extract_fields (record_arg p1) args | Tpat_array(args) -> args @@ -455,7 +455,7 @@ let do_set_args erase_mutable q r = match q with make_pat (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: rest -| {pat_desc = Tpat_lazy omega} -> +| {pat_desc = Tpat_lazy _omega} -> begin match r with arg::rest -> make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest @@ -583,7 +583,7 @@ let close_variant env row = let row = Btype.row_repr row in let nm = List.fold_left - (fun nm (tag,f) -> + (fun nm (_tag,f) -> match Btype.row_field_repr f with | Reither(_, _, false, e) -> (* m=false means that this tag is not explicitly matched *) @@ -609,23 +609,8 @@ let row_of_pat pat = not. *) -let generalized_constructor x = - match x with - ({pat_desc = Tpat_construct(_,c,_);pat_env=env},_) -> - c.cstr_generalized - | _ -> assert false - -let clean_env env = - let rec loop = - function - | [] -> [] - | x :: xs -> - if generalized_constructor x then loop xs else x :: loop xs - in - loop env - let full_match closing env = match env with -| ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ -> +| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ -> if c.cstr_consts < 0 then false (* extensions *) else List.length env = c.cstr_consts + c.cstr_nonconsts | ({pat_desc = Tpat_variant _} as p,_) :: _ -> @@ -718,7 +703,7 @@ let pats_of_type ?(always=false) env ty = List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> let cstrs = fst (Env.find_type_descrs path env) in List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs - | Type_record (ldl, _) -> + | Type_record _ -> let labels = snd (Env.find_type_descrs path env) in let fields = List.map (fun ld -> @@ -748,14 +733,6 @@ let rec get_variant_constructors env ty = end | _ -> fatal_error "Parmatch.get_variant_constructors" -let rec map_filter f = - function - [] -> [] - | x :: xs -> - match f x with - | None -> map_filter f xs - | Some y -> y :: map_filter f xs - (* Sends back a pattern that complements constructor tags all_tag *) let complete_constrs p all_tags = let c = @@ -798,7 +775,7 @@ let build_other ext env = match env with ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ -> let c = {c with cstr_name = "*extension*"} in make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty -| ({pat_desc = Tpat_construct (_, cd,_)} as p,_) :: _ -> +| ({pat_desc = Tpat_construct _} as p,_) :: _ -> begin match ext with | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> extra_pat @@ -896,7 +873,7 @@ let build_other ext env = match env with (function f -> Tpat_constant(Const_float (string_of_float f))) 0.0 (fun f -> f +. 1.0) p env -| ({pat_desc = Tpat_array args} as p,_)::_ -> +| ({pat_desc = Tpat_array _} as p,_)::_ -> let all_lengths = List.map (fun (p,_) -> match p.pat_desc with @@ -1020,12 +997,14 @@ type 'a result = | Rnone (* No matching value *) | Rsome of 'a (* This matching value *) +(* let rec try_many f = function | [] -> Rnone | (p,pss)::rest -> match f (p,pss) with | Rnone -> try_many f rest | r -> r +*) let rappend r1 r2 = match r1, r2 with @@ -1214,7 +1193,7 @@ let rec pressure_variants tdefs = function [] -> pressure_variants tdefs (filter_extra pss) | constrs -> let rec try_non_omega = function - (p,pss) :: rem -> + (_p,pss) :: rem -> let ok = pressure_variants tdefs pss in try_non_omega rem && ok | [] -> true @@ -1500,7 +1479,7 @@ let rec le_pat p q = 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,r1), Tpat_variant(l2,None,_) -> + | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) -> l1 = l2 | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs @@ -1555,7 +1534,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with when l1=l2 -> let r=lub p1 p2 in make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env -| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_) +| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_) when l1 = l2 -> p | Tpat_record (l1,closed),Tpat_record (l2,_) -> let rs = record_lubs l1 l2 in @@ -1727,7 +1706,7 @@ module Conv = struct | lst -> Some (mkpat (Ppat_tuple lst)) in mkpat (Ppat_construct(lid, arg)) - | Tpat_variant(label,p_opt,row_desc) -> + | Tpat_variant(label,p_opt,_row_desc) -> let arg = Misc.may_map loop p_opt in mkpat (Ppat_variant(label, arg)) | Tpat_record (subpatterns, _closed_flag) -> @@ -1915,7 +1894,7 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt (* Exported unused clause check *) (********************************) -let check_unused pred tdefs casel = +let check_unused pred casel = if Warnings.is_active Warnings.Unused_match || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then let rec do_rec pref = function diff --git a/typing/parmatch.mli b/typing/parmatch.mli index e2122a686..3dcb6dde1 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -71,7 +71,7 @@ val check_unused: (string, constructor_description) Hashtbl.t -> (string, label_description) Hashtbl.t -> Parsetree.pattern -> pattern option) -> - Env.t -> case list -> unit + case list -> unit (* Irrefutability tests *) val irrefutable : pattern -> bool diff --git a/typing/path.ml b/typing/path.ml index 035f12221..bbce3c516 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -23,33 +23,33 @@ let nopos = -1 let rec same p1 p2 = match (p1, p2) with (Pident id1, Pident id2) -> Ident.same id1 id2 - | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 && same p1 p2 + | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2 | (Papply(fun1, arg1), Papply(fun2, arg2)) -> same fun1 fun2 && same arg1 arg2 | (_, _) -> false let rec isfree id = function Pident id' -> Ident.same id id' - | Pdot(p, s, pos) -> isfree id p + | Pdot(p, _s, _pos) -> isfree id p | Papply(p1, p2) -> isfree id p1 || isfree id p2 let rec binding_time = function Pident id -> Ident.binding_time id - | Pdot(p, s, pos) -> binding_time p + | Pdot(p, _s, _pos) -> binding_time p | Papply(p1, p2) -> max (binding_time p1) (binding_time p2) -let kfalse x = false +let kfalse _ = false let rec name ?(paren=kfalse) = function Pident id -> Ident.name id - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" let rec head = function Pident id -> id - | Pdot(p, s, pos) -> head p - | Papply(p1, p2) -> assert false + | Pdot(p, _s, _pos) -> head p + | Papply _ -> assert false let heads p = let rec heads p acc = match p with diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 944c104da..1e29dfb38 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -53,9 +53,9 @@ let ident_pervasive = Ident.create_persistent "Pervasives" let rec tree_of_path = function | Pident id -> Oide_ident (ident_name id) - | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive -> + | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive -> Oide_ident s - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> Oide_dot (tree_of_path p, s) | Papply(p1, p2) -> Oide_apply (tree_of_path p1, tree_of_path p2) @@ -63,9 +63,9 @@ let rec tree_of_path = function let rec path ppf = function | Pident id -> ident ppf id - | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive -> + | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive -> pp_print_string ppf s - | Pdot(p, s, pos) -> + | Pdot(p, s, _pos) -> path ppf p; pp_print_char ppf '.'; pp_print_string ppf s @@ -118,7 +118,7 @@ let rec safe_repr v = function let rec list_of_memo = function Mnil -> [] - | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem let print_name ppf = function @@ -237,7 +237,7 @@ module Path2 = struct let rec compare p1 p2 = (* must ignore position when comparing paths *) match (p1, p2) with - (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> + (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> let c = compare p1 p2 in if c <> 0 then c else String.compare s1 s2 | (Papply(fun1, arg1), Papply(fun2, arg2)) -> @@ -317,7 +317,7 @@ let set_printing_env env = (* printf "Recompute printing_map.@."; *) let cont = Env.iter_types - (fun p (p', decl) -> + (fun p (p', _decl) -> let (p1, s1) = normalize_type_path env p' ~cache:true in (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) if s1 = Id then @@ -483,7 +483,7 @@ let rec mark_loops_rec visited ty = mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl | Tconstr(p, tyl, _) -> - let (p', s) = best_type_path p in + let (_p', s) = best_type_path p in List.iter (mark_loops_rec visited) (apply_subst s tyl) | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl @@ -494,7 +494,7 @@ let rec mark_loops_rec visited ty = if not (static_row row) then visited_objects := px :: !visited_objects; match row.row_name with - | Some(p, tyl) when namable_row row -> + | Some(_p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> iter_row (mark_loops_rec visited) row @@ -575,7 +575,7 @@ let rec tree_of_typexp sch ty = pr_arrow l ty1 ty2 | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) - | Tconstr(p, tyl, abbrev) -> + | Tconstr(p, tyl, _abbrev) -> let p', s = best_type_path p in let tyl' = apply_subst s tyl in if is_nth s then tree_of_typexp sch (List.hd tyl') else @@ -719,19 +719,19 @@ and tree_of_typfields sch rest = function let (fields, rest) = tree_of_typfields sch rest l in (field :: fields, rest) -let typexp sch prio ppf ty = +let typexp sch ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) -let type_expr ppf ty = typexp false 0 ppf ty +let type_expr ppf ty = typexp false ppf ty -and type_sch ppf ty = typexp true 0 ppf ty +and type_sch ppf ty = typexp true ppf ty -and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty +and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty (* Maxence *) let type_scheme_max ?(b_reset_names=true) ppf ty = if b_reset_names then reset_names () ; - typexp true 0 ppf ty + typexp true ppf ty (* End Maxence *) let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty @@ -808,7 +808,7 @@ let rec tree_of_type_decl id decl = mark_loops_constructor_arguments c.cd_args; may mark_loops c.cd_res) cstrs - | Type_record(l, rep) -> + | Type_record(l, _rep) -> List.iter (fun l -> mark_loops l.ld_type) l | Type_open -> () end; @@ -860,7 +860,7 @@ let rec tree_of_type_decl id decl = | Type_variant cstrs -> tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), decl.type_private - | Type_record(lbls, rep) -> + | Type_record(lbls, _rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private | Type_open -> @@ -999,7 +999,7 @@ let tree_of_metho sch concrete csil (lab, kind, ty) = else csil let rec prepare_class_type params = function - | Cty_constr (p, tyl, cty) -> + | Cty_constr (_p, tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) @@ -1130,7 +1130,7 @@ let tree_of_cltype_declaration id cl rs = let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in List.exists - (fun (lab, _, ty) -> + (fun (lab, _, _) -> not (lab = dummy_method || Concr.mem lab sign.csig_concr)) fields || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false @@ -1172,7 +1172,7 @@ let dummy = } let hide_rec_items = function - | Sig_type(id, decl, rs) ::rem + | Sig_type(id, _decl, rs) ::rem when rs = Trec_first && not !Clflags.real_paths -> let rec get_ids = function Sig_type (id, _, Trec_next) :: rem -> @@ -1264,7 +1264,7 @@ let modtype_declaration id ppf decl = let rec print_items showval env = function | [] -> [] | item :: rem as items -> - let (sg, rem) = filter_rem_sig item rem in + let (_sg, rem) = filter_rem_sig item rem in hide_rec_items items; let trees = trees_of_sigitem item in List.map (fun d -> (d, showval env item)) trees @ @@ -1362,7 +1362,7 @@ let print_tags ppf fields = fprintf ppf "`%s" t; List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields -let has_explanation unif t3 t4 = +let has_explanation t3 t4 = match t3.desc, t4.desc with Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _ | Tnil, Tconstr _ | Tconstr _, Tnil @@ -1371,12 +1371,12 @@ let has_explanation unif t3 t4 = | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l' | _ -> false -let rec mismatch unif = function +let rec mismatch = function (_, t) :: (_, t') :: rem -> - begin match mismatch unif rem with + begin match mismatch rem with Some _ as m -> m | None -> - if has_explanation unif t t' then Some(t,t') else None + if has_explanation t t' then Some(t,t') else None end | [] -> None | _ -> assert false @@ -1385,12 +1385,12 @@ let explanation unif t3 t4 ppf = match t3.desc, t4.desc with | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> fprintf ppf "@,Self type cannot escape its class" - | Tconstr (p, tl, _), Tvar _ + | Tconstr (p, _, _), Tvar _ when unif && t4.level < Path.binding_time p -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" path p - | Tvar _, Tconstr (p, tl, _) + | Tvar _, Tconstr (p, _, _) when unif && t3.level < Path.binding_time p -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" @@ -1492,7 +1492,7 @@ let unification_error env unif tr txt1 ppf txt2 = reset (); trace_same_names tr; let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in - let mis = mismatch unif tr in + let mis = mismatch tr in match tr with | [] | _ :: [] -> assert false | t1 :: t2 :: tr -> @@ -1547,7 +1547,7 @@ let report_subtyping_error ppf env tr1 txt1 tr2 = and tr2 = List.map prepare_expansion tr2 in fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; if tr2 = [] then fprintf ppf "@]" else - let mis = mismatch true tr2 in + let mis = mismatch tr2 in fprintf ppf "%a%t@]" (trace false (mis = None) "is not compatible with type") tr2 (explanation true mis)) diff --git a/typing/printtyped.ml b/typing/printtyped.ml index f83b70473..15ae01f4a 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -231,7 +231,7 @@ and pattern i ppf x = | Tpat_variant (l, po, _) -> line i ppf "Tpat_variant \"%s\"\n" l; option i pattern ppf po; - | Tpat_record (l, c) -> + | Tpat_record (l, _c) -> line i ppf "Tpat_record\n"; list i longident_x_pattern ppf l; | Tpat_array (l) -> @@ -291,7 +291,7 @@ and expression i ppf x = line i ppf "Texp_apply\n"; expression i ppf e; list i label_x_expression ppf l; - | Texp_match (e, l1, l2, partial) -> + | Texp_match (e, l1, l2, _partial) -> line i ppf "Texp_match\n"; expression i ppf e; list i case ppf l1; diff --git a/typing/stypes.ml b/typing/stypes.ml index 8a3e1096a..140b79e2f 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -44,8 +44,8 @@ let get_location ti = | Ti_expr e -> e.exp_loc | Ti_class c -> c.cl_loc | Ti_mod m -> m.mod_loc - | An_call (l, k) -> l - | An_ident (l, s, k) -> l + | An_call (l, _k) -> l + | An_ident (l, _s, _k) -> l ;; let annotations = ref ([] : annotation list);; diff --git a/typing/subst.ml b/typing/subst.ml index 5ea5260e6..59c54efd8 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -82,7 +82,7 @@ let modtype_path s = function with Not_found -> p end | Pdot(p, n, pos) -> Pdot(module_path s p, n, pos) - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Subst.modtype_path" let type_path s = function @@ -90,7 +90,7 @@ let type_path s = function begin try Tbl.find id s.types with Not_found -> p end | Pdot(p, n, pos) -> Pdot(module_path s p, n, pos) - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Subst.type_path" let type_path s p = @@ -147,7 +147,7 @@ let rec typexp s ty = ty.desc <- Tsubst ty'; ty'.desc <- begin match desc with - | Tconstr(p, tl, abbrev) -> + | Tconstr(p, tl, _abbrev) -> Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil) | Tpackage(p, n, tl) -> Tpackage(modtype_path s p, n, List.map (typexp s) tl) @@ -197,7 +197,7 @@ let rec typexp s ty = | None -> Tvariant row end - | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent -> + | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> Tlink (typexp s t2) | _ -> copy_type_desc (typexp s) desc end; @@ -345,13 +345,13 @@ let extension_constructor s ext = let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) - | Sig_type(id, d, _) :: sg -> + | Sig_type(id, _, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Sig_module(id, mty, _) :: sg -> + | Sig_module(id, _, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg - | Sig_modtype(id, d) :: sg -> + | Sig_modtype(id, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) (id' :: idents) sg @@ -370,7 +370,7 @@ let rec modtype s = function begin try Tbl.find id s.modtypes with Not_found -> mty end | Pdot(p, n, pos) -> Mty_ident(Pdot(module_path s p, n, pos)) - | Papply(p1, p2) -> + | Papply _ -> fatal_error "Subst.modtype" end | Mty_signature sg -> @@ -392,19 +392,19 @@ and signature s sg = and signature_component s comp newid = match comp with - Sig_value(id, d) -> + Sig_value(_id, d) -> Sig_value(newid, value_description s d) - | Sig_type(id, d, rs) -> + | Sig_type(_id, d, rs) -> Sig_type(newid, type_declaration s d, rs) - | Sig_typext(id, ext, es) -> + | Sig_typext(_id, ext, es) -> Sig_typext(newid, extension_constructor s ext, es) - | Sig_module(id, d, rs) -> + | Sig_module(_id, d, rs) -> Sig_module(newid, module_declaration s d, rs) - | Sig_modtype(id, d) -> + | Sig_modtype(_id, d) -> Sig_modtype(newid, modtype_declaration s d) - | Sig_class(id, d, rs) -> + | Sig_class(_id, d, rs) -> Sig_class(newid, class_declaration s d, rs) - | Sig_class_type(id, d, rs) -> + | Sig_class_type(_id, d, rs) -> Sig_class_type(newid, cltype_declaration s d, rs) and module_declaration s decl = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 884fdfe58..b7f44ca2b 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -123,18 +123,18 @@ let rec constructor_type constr cty = match cty with Cty_constr (_, _, cty) -> constructor_type constr cty - | Cty_signature sign -> + | Cty_signature _ -> constr | Cty_arrow (l, ty, cty) -> Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) let rec class_body cty = match cty with - Cty_constr (_, _, cty') -> + Cty_constr _ -> cty (* Only class bodies can be abbreviated *) - | Cty_signature sign -> + | Cty_signature _ -> cty - | Cty_arrow (_, ty, cty) -> + | Cty_arrow (_, _, cty) -> class_body cty let extract_constraints cty = @@ -182,7 +182,7 @@ let closed_class cty = let rec limited_generalize rv = function - Cty_constr (path, params, cty) -> + Cty_constr (_path, params, cty) -> List.iter (Ctype.limited_generalize rv) params; limited_generalize rv cty | Cty_signature sign -> @@ -365,10 +365,10 @@ let make_method loc cl_num expr = (*******************************) -let add_val env loc lab (mut, virt, ty) val_sig = +let add_val lab (mut, virt, ty) val_sig = let virt = try - let (mut', virt', ty') = Vars.find lab val_sig in + let (_mut', virt', _ty') = Vars.find lab val_sig in if virt' = Concrete then virt' else virt with Not_found -> virt in @@ -393,7 +393,7 @@ let rec class_type_field env self_type meths parent.cltyp_type in let val_sig = - Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in + Vars.fold add_val cl_sig.csig_vars val_sig in (mkctf (Tctf_inherit parent) :: fields, val_sig, concr_meths, inher) @@ -401,7 +401,7 @@ let rec class_type_field env self_type meths let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, - add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher) + add_val lab (mut, virt, ty) val_sig, concr_meths, inher) | Pctf_method (lab, priv, virt, sty) -> let cty = @@ -569,7 +569,7 @@ let rec class_field self_loc cl_num self_type meths vars None -> (val_env, met_env, par_env) | Some name -> - let (id, val_env, met_env, par_env) = + let (_id, val_env, met_env, par_env) = enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type val_env met_env par_env @@ -790,7 +790,7 @@ and class_structure cl_num final val_env met_env loc Ctype.unify val_env self_type (Ctype.newvar ()); let sign = {csig_self = public_self; - csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; + csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars; csig_concr = concr_meths; csig_inher = inher} in let methods = get_methods self_type in @@ -804,7 +804,7 @@ and class_structure cl_num final val_env met_env loc let mets = virtual_methods {sign with csig_self = self_type} in let vals = Vars.fold - (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) sign.csig_vars [] in if mets <> [] || vals <> [] then raise(Error(loc, val_env, Virtual_class(true, final, mets, vals))); @@ -838,7 +838,7 @@ and class_structure cl_num final val_env met_env loc Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms end; let fields = List.map Lazy.force (List.rev fields) in - let meths = Meths.map (function (id, ty) -> id) !meths in + let meths = Meths.map (function (id, _ty) -> id) !meths in (* Check for private methods made public *) let pub_meths' = @@ -946,7 +946,7 @@ and class_expr cl_num val_env met_env scl = end; let pv = List.map - begin fun (id, id_loc, id', ty) -> + begin fun (id, id_loc, id', _ty) -> let path = Pident id' in (* do not mark the value as being used *) let vd = Env.find_value path val_env' in @@ -1415,7 +1415,7 @@ let class_infos define_class kind let mets = virtual_methods sign in let vals = Vars.fold - (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) sign.csig_vars [] in if mets <> [] || vals <> [] then raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets, @@ -1541,8 +1541,8 @@ let final_decl env define_class (* (cl.pci_variance, cl.pci_loc)) *) let extract_type_decls - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, required) decls = + (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr, + _arity, _pub_meths, _coe, _expr, required) decls = (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls let merge_type_decls @@ -1552,8 +1552,8 @@ let merge_type_decls arity, pub_meths, coe, expr, req) let final_env define_class env - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, req) = + (id, _id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + _arity, _pub_meths, _coe, _expr, _req) = (* Add definitions after cleaning them *) Env.add_type ~check:true obj_id (Subst.type_declaration Subst.identity obj_abbr) ( @@ -1567,7 +1567,7 @@ let final_env define_class env (* Check that #c is coercible to c if there is a self-coercion *) let check_coercions env (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coercion_locs, expr, req) = + arity, pub_meths, coercion_locs, _expr, req) = begin match coercion_locs with [] -> () | loc :: _ -> let cl_ty, obj_ty = @@ -1657,7 +1657,7 @@ let rec unify_parents env ty cl = Ctype.unify env ty (Ctype.instance env body) with Not_found -> () - | exn -> assert false + | _exn -> assert false end | Tcl_structure st -> unify_parents_struct env ty st | Tcl_fun (_, _, _, cl, _) @@ -1722,7 +1722,7 @@ let report_error env ppf = function fprintf ppf "@[This class expression is not a class structure; it has type@ %a@]" Printtyp.class_type clty - | Cannot_apply clty -> + | Cannot_apply _ -> fprintf ppf "This class expression is not a class function, it cannot be applied" | Apply_wrong_label l -> @@ -1846,7 +1846,7 @@ let report_error env ppf = function fprintf ppf "This object is expected to have type") (function ppf -> fprintf ppf "but actually has type") - | Mutability_mismatch (lab, mut) -> + | Mutability_mismatch (_lab, mut) -> let mut1, mut2 = if mut = Immutable then "mutable", "immutable" else "immutable", "mutable" in diff --git a/typing/typecore.ml b/typing/typecore.ml index 2c8fe8cb9..b34b007bc 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -83,7 +83,7 @@ exception Error_forward of Location.error (* Forward declaration, to be filled in by Typemod.type_module *) let type_module = - ref ((fun env md -> assert false) : + ref ((fun _env _md -> assert false) : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) (* Forward declaration, to be filled in by Typemod.type_open *) @@ -98,7 +98,7 @@ let type_package = (* Forward declaration, to be filled in by Typeclass.class_structure *) let type_object = - ref (fun env s -> assert false : + ref (fun _env _s -> assert false : Env.t -> Location.t -> Parsetree.class_structure -> Typedtree.class_structure * Types.class_signature * string list) @@ -337,7 +337,7 @@ let extract_concrete_variant env ty = | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found -let extract_label_names sexp env ty = +let extract_label_names env ty = try let (_, _,fields) = extract_concrete_record env ty in List.map (fun l -> l.Types.ld_id) fields @@ -415,7 +415,7 @@ let finalize_variant pat = begin match opat with None -> assert false | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end - | Reither (c, l, true, e) when not (row_fixed row) -> + | Reither (c, _l, true, e) when not (row_fixed row) -> set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; @@ -486,7 +486,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = let rec unify_vars p1_vs p2_vs = let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in match p1_vs, p2_vs with - | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 -> + | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 else begin @@ -646,7 +646,7 @@ module NameChoice(Name : sig end) = struct open Name - let get_type_path env d = + let get_type_path d = match (repr (get_type d)).desc with | Tconstr(p, _, _) -> p | _ -> assert false @@ -672,9 +672,9 @@ end) = struct else unique eq (x :: acc) rem let ambiguous_types env lbl others = - let tpath = get_type_path env lbl in + let tpath = get_type_path lbl in let others = - List.map (fun (lbl, _) -> get_type_path env lbl) others in + List.map (fun (lbl, _) -> get_type_path lbl) others in let tpaths = unique (compare_type_path env) [tpath] others in match tpaths with [_] -> [] @@ -682,7 +682,7 @@ end) = struct let disambiguate_by_type env tpath lbls = let check_type (lbl, _) = - let lbl_tpath = get_type_path env lbl in + let lbl_tpath = get_type_path lbl in compare_type_path env tpath lbl_tpath in List.find check_type lbls @@ -717,8 +717,8 @@ end) = struct (* Check if non-principal type is affecting result *) match lbls with [] -> warn_pr () - | (lbl', use') :: rest -> - let lbl_tpath = get_type_path env lbl' in + | (lbl', _use') :: rest -> + let lbl_tpath = get_type_path lbl' in if not (compare_type_path env tpath lbl_tpath) then warn_pr () else let paths = ambiguous_types env lbl rest in @@ -745,7 +745,7 @@ end) = struct let tpl = List.map (fun (lbl, _) -> - let tp0 = get_type_path env lbl in + let tp0 = get_type_path lbl in let tp = expand_path env tp0 in (tp0, tp)) lbls @@ -780,7 +780,7 @@ module Label = NameChoice (struct | Record_inlined _ | Record_extension -> false end) -let disambiguate_label_by_ids keep env closed ids labels = +let disambiguate_label_by_ids keep closed ids labels = let check_ids (lbl, _) = let lbls = Hashtbl.create 8 in Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; @@ -824,7 +824,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = let (ok, labels) = match opath with Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *) - | _ -> disambiguate_label_by_ids (opath=None) env closed ids scope + | _ -> disambiguate_label_by_ids (opath=None) closed ids scope in if ok then Label.disambiguate lid env opath labels ~warn ~scope else fst (List.hd labels) (* will fail later *) @@ -836,9 +836,9 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = (Warnings.Not_principal "this type-based record disambiguation") else begin match List.rev !w_amb with - (_,types)::others as amb -> + (_,types)::_ as amb -> let paths = - List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in + List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in let path = List.hd paths in if List.for_all (compare_type_path env path) (List.tl paths) then Location.prerr_warning loc @@ -1269,7 +1269,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env unify_pat_types loc !env (instance_def (Predef.type_array ty_elt)) expected_ty; let spl_ann = List.map (fun p -> (p,newvar())) spl in - map_fold_cont (fun (p,t) -> type_pat p ty_elt) spl_ann (fun pl -> + map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl -> rp k { pat_desc = Tpat_array pl; pat_loc = loc; pat_extra=[]; @@ -1418,12 +1418,12 @@ let check_unused ?(lev=get_current_level ()) env expected_ty cases = Some pat when refute -> raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat)) | r -> r) - env cases + cases let add_pattern_variables ?check ?check_as env = let pv = get_ref pattern_variables in (List.fold_right - (fun (id, ty, name, loc, as_var) env -> + (fun (id, ty, _name, loc, as_var) env -> let check = if as_var then check_as else check in Env.add_value ?check id {val_type = ty; val_kind = Val_reg; Types.val_loc = loc; @@ -1495,7 +1495,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = pattern_variables := []; let (val_env, met_env, par_env) = List.fold_right - (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) -> + (fun (id, ty, _name, loc, as_var) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound; val_attributes = []; @@ -1549,7 +1549,7 @@ let rec is_nonexpansive exp = match exp.exp_desc with Texp_ident(_,_,_) -> true | Texp_constant _ -> true - | Texp_let(rec_flag, pat_exp_list, body) -> + | Texp_let(_rec_flag, pat_exp_list, body) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body | Texp_function _ -> true @@ -1571,11 +1571,11 @@ let rec is_nonexpansive exp = (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) lbl_exp_list && is_nonexpansive_opt opt_init_exp - | Texp_field(exp, lbl, _) -> is_nonexpansive exp + | Texp_field(exp, _, _) -> is_nonexpansive exp | Texp_array [] -> true - | Texp_ifthenelse(cond, ifso, ifnot) -> + | Texp_ifthenelse(_cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot - | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) + | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true (* Note: nonexpansive only means no _observable_ side effects *) @@ -1815,7 +1815,7 @@ let iter_ppat f p = | Ppat_tuple lst -> List.iter f lst | Ppat_exception p | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p - | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args + | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args let contains_polymorphic_variant p = let rec loop p = @@ -1860,7 +1860,7 @@ let check_absent_variant env = (* Duplicate types of values in the environment *) (* XXX Should we do something about global type variables too? *) -let duplicate_ident_types loc caselist env = +let duplicate_ident_types caselist env = let caselist = List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in let idents = all_idents_cases caselist in @@ -2080,7 +2080,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = let ty = expand_head env ty_fun in if List.memq ty seen then () else match ty.desc with - Tarrow (l, ty_arg, ty_fun, com) -> + Tarrow (_l, ty_arg, ty_fun, _com) -> (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); lower_args (ty::seen) ty_fun | _ -> () @@ -2252,7 +2252,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = let opt_exp = match opt_exp, lbl_exp_list with None, _ -> None - | Some exp, (lid, lbl, lbl_exp) :: _ -> + | Some exp, (_lid, lbl, _lbl_exp) :: _ -> let ty_exp = instance env exp.exp_type in let unify_kept lbl = (* do not connect overridden labels *) @@ -2276,7 +2276,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin let present_indices = List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in - let label_names = extract_label_names sexp env ty_expected in + let label_names = extract_label_names env ty_expected in let rec missing_labels n = function [] -> [] | lbl :: rem -> @@ -2295,7 +2295,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_field(srecord, lid) -> - let (record, label, _) = type_label_access env loc srecord lid in + let (record, label, _) = type_label_access env srecord lid in let (_, ty_arg, ty_res) = instance_label false label in unify_exp env record ty_res; rue { @@ -2305,7 +2305,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> - let (record, label, opath) = type_label_access env loc srecord lid in + let (record, label, opath) = type_label_access env srecord lid in let ty_record = if opath = None then newvar () else record.exp_type in let (label_loc, label, newval) = type_label_exp false env loc ty_record (lid, label, snewval) in @@ -2446,7 +2446,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = && free_variables ~env ty' = [] -> if not gen && (* first try a single coercion *) let snap = snapshot () in - let ty, b = enlarge_type env ty' in + let ty, _b = enlarge_type env ty' in try force (); Ctype.unify env arg.exp_type ty; true with Unify _ -> @@ -2511,7 +2511,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = begin try let (meth, exp, typ) = match obj.exp_desc with - Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) -> + Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) -> obj_meths := Some meths; let (id, typ) = filter_self_method env met Private meths privty @@ -2520,7 +2520,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = Location.prerr_warning loc (Warnings.Undeclared_virtual_method met); (Tmeth_val id, None, typ) - | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> + | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> let valid_methods = List.map fst methods in @@ -2868,21 +2868,21 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_extra = (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } | Pexp_pack m -> - let (p, nl, tl) = + let (p, nl) = match Ctype.expand_head env (instance env ty_expected) with - {desc = Tpackage (p, nl, tl)} -> + {desc = Tpackage (p, nl, _tl)} -> if !Clflags.principal && (Ctype.expand_head env ty_expected).level < Btype.generic_level then Location.prerr_warning loc (Warnings.Not_principal "this module packing"); - (p, nl, tl) + (p, nl) | {desc = Tvar _} -> raise (Error (loc, env, Cannot_infer_signature)) | _ -> raise (Error (loc, env, Not_a_packed_module ty_expected)) in - let (modl, tl') = !type_package env m p nl tl in + let (modl, tl') = !type_package env m p nl in rue { exp_desc = Texp_pack modl; exp_loc = loc; exp_extra = []; @@ -2979,7 +2979,7 @@ and type_function ?in_function loc attrs env ty_expected l caselist = exp_env = env } -and type_label_access env loc srecord lid = +and type_label_access env srecord lid = if !Clflags.principal then begin_def (); let record = type_exp ~recarg:Allowed env srecord in if !Clflags.principal then begin @@ -3707,7 +3707,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = then correct_levels ty_arg else ty_arg and ty_res, env = if has_gadts && not !Clflags.principal then - correct_levels ty_res, duplicate_ident_types loc caselist env + correct_levels ty_res, duplicate_ident_types caselist env else ty_res, env in let do_init = has_gadts || List.length caselist > 1 in @@ -4046,7 +4046,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let type_binding env rec_flag spat_sexp_list scope = Typetexp.reset_type_variables(); - let (pat_exp_list, new_env, unpacks) = + let (pat_exp_list, new_env, _unpacks) = type_let ~check:(fun s -> Warnings.Unused_value_declaration s) ~check_strict:(fun s -> Warnings.Unused_value_declaration s) @@ -4055,7 +4055,7 @@ let type_binding env rec_flag spat_sexp_list scope = (pat_exp_list, new_env) let type_let env rec_flag spat_sexp_list scope = - let (pat_exp_list, new_env, unpacks) = + let (pat_exp_list, new_env, _unpacks) = type_let env rec_flag spat_sexp_list scope false in (pat_exp_list, new_env) @@ -4071,7 +4071,7 @@ let type_expression env sexp = match sexp.pexp_desc with Pexp_ident lid -> (* Special case for keeping type variables when looking-up a variable *) - let (path, desc) = Env.lookup_value lid.txt env in + let (_path, desc) = Env.lookup_value lid.txt env in {exp with exp_type = desc.val_type} | _ -> exp diff --git a/typing/typecore.mli b/typing/typecore.mli index a28e557b2..0939c2e84 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -140,7 +140,7 @@ val type_object: Typedtree.class_structure * Types.class_signature * string list) ref val type_package: (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> - type_expr list -> Typedtree.module_expr * type_expr list) ref + Typedtree.module_expr * type_expr list) ref val create_package_type : Location.t -> Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0d6fa2786..24f15fbc5 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -157,7 +157,7 @@ let make_params env params = in List.map make_param params -let transl_labels loc env closed lbls = +let transl_labels env closed lbls = assert (lbls <> []); let all_labels = ref StringSet.empty in List.iter @@ -189,21 +189,21 @@ let transl_labels loc env closed lbls = lbls in lbls, lbls' -let transl_constructor_arguments loc env closed = function +let transl_constructor_arguments env closed = function | Pcstr_tuple l -> let l = List.map (transl_simple_type env closed) l in Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l | Pcstr_record l -> - let lbls, lbls' = transl_labels loc env closed l in + let lbls, lbls' = transl_labels env closed l in Types.Cstr_record lbls', Cstr_record lbls -let make_constructor loc env type_path type_params sargs sret_type = +let make_constructor env type_path type_params sargs sret_type = match sret_type with | None -> let args, targs = - transl_constructor_arguments loc env true sargs + transl_constructor_arguments env true sargs in targs, None, args, None | Some sret_type -> @@ -212,7 +212,7 @@ let make_constructor loc env type_path type_params sargs sret_type = let z = narrow () in reset_type_variables (); let args, targs = - transl_constructor_arguments loc env false sargs + transl_constructor_arguments env false sargs in let tret_type = transl_simple_type env false sret_type in let ret_type = tret_type.ctyp_type in @@ -257,7 +257,7 @@ let transl_declaration env sdecl id = let make_cstr scstr = let name = Ident.create scstr.pcd_name.txt in let targs, tret_type, args, ret_type = - make_constructor scstr.pcd_loc env (Path.Pident id) params + make_constructor env (Path.Pident id) params scstr.pcd_args scstr.pcd_res in let tcstr = @@ -280,7 +280,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let lbls, lbls' = transl_labels sdecl.ptype_loc env true lbls in + let lbls, lbls' = transl_labels env true lbls in let rep = if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' then Record_float @@ -514,7 +514,7 @@ let check_well_founded env loc path to_check ty = if fini then () else try visited := TypeMap.add ty exp_nodes !visited; match ty.desc with - | Tconstr(p, args, _) + | Tconstr(p, _, _) when not (TypeSet.is_empty exp_nodes) || to_check p -> let ty' = Ctype.try_expand_once_opt env ty in let ty0 = if TypeSet.is_empty exp_nodes then ty else ty0 in @@ -741,7 +741,7 @@ let compute_variance_type env check (required, loc) decl tyl = if fvl = [] then () else let tvl2 = ref TypeMap.empty in List.iter2 - (fun ty (p,n,i) -> + (fun ty (p,n,_) -> if Btype.is_Tvar ty then () else let v = if p then if n then full else covariant else conjugate covariant in @@ -823,7 +823,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl let fvl = List.map (Ctype.free_variables ?env:None) tyl in let _ = List.fold_left2 - (fun (fv1,fv2) ty (c,n,i) -> + (fun (fv1,fv2) ty (c,n,_) -> match fv2 with [] -> assert false | fv :: fv2 -> (* fv1 @ fv2 = free_variables of other parameters *) @@ -915,14 +915,14 @@ let rec compute_properties_fixpoint env decls required variances immediacies = in let new_variances = List.map2 - (fun (id, decl) -> compute_variance_decl new_env false decl) + (fun (_id, decl) -> compute_variance_decl new_env false decl) new_decls required in let new_variances = List.map2 (List.map2 Variance.union) new_variances variances in let new_immediacies = List.map - (fun (id, decl) -> compute_immediacy new_env decl) + (fun (_id, decl) -> compute_immediacy new_env decl) new_decls in if new_variances <> variances || new_immediacies <> immediacies then @@ -947,7 +947,7 @@ let rec compute_properties_fixpoint env decls required variances immediacies = new_decls, new_env end -let init_variance (id, decl) = +let init_variance (_id, decl) = List.map (fun _ -> Variance.null) decl.type_params let add_injectivity = @@ -962,7 +962,7 @@ let add_injectivity = let compute_variance_decls env cldecls = let decls, required = List.fold_right - (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) -> + (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) -> let variance = List.map snd ci.ci_params in (obj_id, obj_abbr) :: decls, (add_injectivity variance, ci.ci_loc) :: req) @@ -1162,7 +1162,7 @@ let transl_type_decl env rec_flag sdecl_list = (* Keep original declaration *) let final_decls = List.map2 - (fun tdecl (id2, decl) -> + (fun tdecl (_id2, decl) -> { tdecl with typ_type = decl } ) tdecls final_decls in @@ -1178,7 +1178,7 @@ let transl_extension_constructor env type_path type_params match sext.pext_kind with Pext_decl(sargs, sret_type) -> let targs, tret_type, args, ret_type = - make_constructor sext.pext_loc env type_path typext_params + make_constructor env type_path typext_params sargs sret_type in args, ret_type, Text_decl(targs, tret_type) @@ -1633,7 +1633,7 @@ let abstract_type_decl arity = generalize_decl decl; decl -let approx_type_decl env sdecl_list = +let approx_type_decl sdecl_list = List.map (fun sdecl -> (Ident.create sdecl.ptype_name.txt, @@ -1684,7 +1684,7 @@ let explain_unbound_single ppf tv ty = let row = Btype.row_repr row in if row.row_more == tv then trivial ty else explain_unbound ppf tv row.row_fields - (fun (l,f) -> match Btype.row_field_repr f with + (fun (_l,f) -> match Btype.row_field_repr f with Rpresent (Some t) -> t | Reither (_,[t],_,_) -> t | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) diff --git a/typing/typedecl.mli b/typing/typedecl.mli index fa57b17c5..ef46c9d7a 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -40,7 +40,7 @@ val transl_with_constraint: val abstract_type_decl: int -> type_declaration val approx_type_decl: - Env.t -> Parsetree.type_declaration list -> + Parsetree.type_declaration list -> (Ident.t * type_declaration) list val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 436cabc70..3db9f6a50 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -519,10 +519,10 @@ and 'a class_infos = let iter_pattern_desc f = function | Tpat_alias(p, _, _) -> f p | Tpat_tuple patl -> List.iter f patl - | Tpat_construct(_, cstr, patl) -> List.iter f patl + | Tpat_construct(_, _, patl) -> List.iter f patl | Tpat_variant(_, pat, _) -> may f pat | Tpat_record (lbl_pat_list, _) -> - List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list + List.iter (fun (_, _, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 | Tpat_lazy p -> f p diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index cc409d4db..94249782c 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -150,7 +150,7 @@ module MakeIterator(Iter : IteratorArgument) : sig List.iter (fun (ci, _) -> iter_class_declaration ci) list | Tstr_class_type list -> List.iter - (fun (id, _, ct) -> iter_class_type_declaration ct) + (fun (_, _, ct) -> iter_class_type_declaration ct) list | Tstr_include incl -> iter_module_expr incl.incl_mod | Tstr_attribute _ -> @@ -174,13 +174,13 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_constructor_arguments cd.cd_args; option iter_core_type cd.cd_res; - and iter_type_parameter (ct, v) = + and iter_type_parameter (ct, _v) = iter_core_type ct and iter_type_declaration decl = Iter.enter_type_declaration decl; List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, loc) -> + List.iter (fun (ct1, ct2, _loc) -> iter_core_type ct1; iter_core_type ct2 ) decl.typ_cstrs; @@ -228,19 +228,19 @@ module MakeIterator(Iter : IteratorArgument) : sig begin match pat.pat_desc with Tpat_any -> () - | Tpat_var (id, _) -> () + | Tpat_var _ -> () | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant cst -> () + | Tpat_constant _ -> () | Tpat_tuple list -> List.iter iter_pattern list | Tpat_construct (_, _, args) -> List.iter iter_pattern args - | Tpat_variant (label, pato, _) -> + | Tpat_variant (_, pato, _) -> begin match pato with None -> () | Some pat -> iter_pattern pat end - | Tpat_record (list, closed) -> + | Tpat_record (list, _closed) -> List.iter (fun (_, _, pat) -> iter_pattern pat) list | Tpat_array list -> List.iter iter_pattern list | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 @@ -258,22 +258,22 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_core_type ct | Texp_coerce (cty1, cty2) -> option iter_core_type cty1; iter_core_type cty2 - | Texp_open (_, path, _, _) -> () + | Texp_open _ -> () | Texp_poly cto -> option iter_core_type cto - | Texp_newtype s -> ()) + | Texp_newtype _ -> ()) exp.exp_extra; begin match exp.exp_desc with - Texp_ident (path, _, _) -> () - | Texp_constant cst -> () + Texp_ident _ -> () + | Texp_constant _ -> () | Texp_let (rec_flag, list, exp) -> iter_bindings rec_flag list; iter_expression exp - | Texp_function (label, cases, _) -> + | Texp_function (_label, cases, _) -> iter_cases cases | Texp_apply (exp, list) -> iter_expression exp; - List.iter (fun (label, expo) -> + List.iter (fun (_label, expo) -> match expo with None -> () | Some exp -> iter_expression exp @@ -289,7 +289,7 @@ module MakeIterator(Iter : IteratorArgument) : sig List.iter iter_expression list | Texp_construct (_, _, args) -> List.iter iter_expression args - | Texp_variant (label, expo) -> + | Texp_variant (_label, expo) -> begin match expo with None -> () | Some exp -> iter_expression exp @@ -300,9 +300,9 @@ module MakeIterator(Iter : IteratorArgument) : sig None -> () | Some exp -> iter_expression exp end - | Texp_field (exp, _, label) -> + | Texp_field (exp, _, _label) -> iter_expression exp - | Texp_setfield (exp1, _, label, exp2) -> + | Texp_setfield (exp1, _, _label, exp2) -> iter_expression exp1; iter_expression exp2 | Texp_array list -> @@ -320,26 +320,26 @@ module MakeIterator(Iter : IteratorArgument) : sig | Texp_while (exp1, exp2) -> iter_expression exp1; iter_expression exp2 - | Texp_for (id, _, exp1, exp2, dir, exp3) -> + | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> iter_expression exp1; iter_expression exp2; iter_expression exp3 - | Texp_send (exp, meth, expo) -> + | Texp_send (exp, _meth, expo) -> iter_expression exp; begin match expo with None -> () | Some exp -> iter_expression exp end - | Texp_new (path, _, _) -> () - | Texp_instvar (_, path, _) -> () + | Texp_new _ -> () + | Texp_instvar _ -> () | Texp_setinstvar (_, _, _, exp) -> iter_expression exp | Texp_override (_, list) -> - List.iter (fun (path, _, exp) -> + List.iter (fun (_path, _, exp) -> iter_expression exp ) list - | Texp_letmodule (id, _, mexpr, exp) -> + | Texp_letmodule (_id, _, mexpr, exp) -> iter_module_expr mexpr; iter_expression exp | Texp_letexception (cd, exp) -> @@ -360,7 +360,7 @@ module MakeIterator(Iter : IteratorArgument) : sig and iter_package_type pack = Iter.enter_package_type pack; - List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields; + List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; Iter.leave_package_type pack; and iter_signature sg = @@ -427,14 +427,14 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_module_type mty; begin match mty.mty_desc with - Tmty_ident (path, _) -> () - | Tmty_alias (path, _) -> () + Tmty_ident _ -> () + | Tmty_alias _ -> () | Tmty_signature sg -> iter_signature sg - | Tmty_functor (id, _, mtype1, mtype2) -> + | Tmty_functor (_, _, mtype1, mtype2) -> Misc.may iter_module_type mtype1; iter_module_type mtype2 | Tmty_with (mtype, list) -> iter_module_type mtype; - List.iter (fun (path, _, withc) -> + List.iter (fun (_path, _, withc) -> iter_with_constraint withc ) list | Tmty_typeof mexpr -> @@ -457,9 +457,9 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_module_expr mexpr; begin match mexpr.mod_desc with - Tmod_ident (p, _) -> () + Tmod_ident _ -> () | Tmod_structure st -> iter_structure st - | Tmod_functor (id, _, mtype, mexpr) -> + | Tmod_functor (_, _, mtype, mexpr) -> Misc.may iter_module_type mtype; iter_module_expr mexpr | Tmod_apply (mexp1, mexp2, _) -> @@ -470,7 +470,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> iter_module_expr mexpr; iter_module_type mtype - | Tmod_unpack (exp, mty) -> + | Tmod_unpack (exp, _mty) -> iter_expression exp (* iter_module_type mty *) end; @@ -483,14 +483,14 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_constraint (cl, None, _, _, _ ) -> iter_class_expr cl; | Tcl_structure clstr -> iter_class_structure clstr - | Tcl_fun (label, pat, priv, cl, partial) -> + | Tcl_fun (_label, pat, priv, cl, _partial) -> iter_pattern pat; - List.iter (fun (id, _, exp) -> iter_expression exp) priv; + List.iter (fun (_id, _, exp) -> iter_expression exp) priv; iter_class_expr cl | Tcl_apply (cl, args) -> iter_class_expr cl; - List.iter (fun (label, expo) -> + List.iter (fun (_label, expo) -> match expo with None -> () | Some exp -> iter_expression exp @@ -498,10 +498,10 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_let (rec_flat, bindings, ivars, cl) -> iter_bindings rec_flat bindings; - List.iter (fun (id, _, exp) -> iter_expression exp) ivars; + List.iter (fun (_id, _, exp) -> iter_expression exp) ivars; iter_class_expr cl - | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> iter_class_expr cl; iter_class_type clty @@ -515,9 +515,9 @@ module MakeIterator(Iter : IteratorArgument) : sig begin match ct.cltyp_desc with Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (path, _, list) -> + | Tcty_constr (_path, _, list) -> List.iter iter_core_type list - | Tcty_arrow (label, ct, cl) -> + | Tcty_arrow (_label, ct, cl) -> iter_core_type ct; iter_class_type cl end; @@ -535,9 +535,9 @@ module MakeIterator(Iter : IteratorArgument) : sig begin match ctf.ctf_desc with Tctf_inherit ct -> iter_class_type ct - | Tctf_val (s, _mut, _virt, ct) -> + | Tctf_val (_s, _mut, _virt, ct) -> iter_core_type ct - | Tctf_method (s, _priv, _virt, ct) -> + | Tctf_method (_s, _priv, _virt, ct) -> iter_core_type ct | Tctf_constraint (ct1, ct2) -> iter_core_type ct1; @@ -551,22 +551,22 @@ module MakeIterator(Iter : IteratorArgument) : sig begin match ct.ctyp_desc with Ttyp_any -> () - | Ttyp_var s -> () - | Ttyp_arrow (label, ct1, ct2) -> + | Ttyp_var _ -> () + | Ttyp_arrow (_label, ct1, ct2) -> iter_core_type ct1; iter_core_type ct2 | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (path, _, list) -> + | Ttyp_constr (_path, _, list) -> List.iter iter_core_type list - | Ttyp_object (list, o) -> + | Ttyp_object (list, _o) -> List.iter (fun (_, _, t) -> iter_core_type t) list - | Ttyp_class (path, _, list) -> + | Ttyp_class (_path, _, list) -> List.iter iter_core_type list - | Ttyp_alias (ct, s) -> + | Ttyp_alias (ct, _s) -> iter_core_type ct - | Ttyp_variant (list, bool, labels) -> + | Ttyp_variant (list, _bool, _labels) -> List.iter iter_row_field list - | Ttyp_poly (list, ct) -> iter_core_type ct + | Ttyp_poly (_list, ct) -> iter_core_type ct | Ttyp_package pack -> iter_package_type pack end; Iter.leave_core_type ct @@ -580,7 +580,7 @@ module MakeIterator(Iter : IteratorArgument) : sig and iter_row_field rf = match rf with - Ttag (label, _attrs, bool, list) -> + Ttag (_label, _attrs, _bool, list) -> List.iter iter_core_type list | Tinherit ct -> iter_core_type ct @@ -588,18 +588,18 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_class_field cf; begin match cf.cf_desc with - Tcf_inherit (ovf, cl, super, _vals, _meths) -> + Tcf_inherit (_ovf, cl, _super, _vals, _meths) -> iter_class_expr cl | Tcf_constraint (cty, cty') -> iter_core_type cty; iter_core_type cty' - | Tcf_val (lab, _, _, Tcfk_virtual cty, _) -> + | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) -> iter_core_type cty - | Tcf_val (lab, _, _, Tcfk_concrete (_, exp), _) -> + | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) -> iter_expression exp - | Tcf_method (lab, _, Tcfk_virtual cty) -> + | Tcf_method (_lab, _, Tcfk_virtual cty) -> iter_core_type cty - | Tcf_method (lab, _, Tcfk_concrete (_, exp)) -> + | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) -> iter_expression exp | Tcf_initializer exp -> iter_expression exp diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index e309af0c4..43c5cbacc 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -94,7 +94,7 @@ module MakeMap(Map : MapArgument) = struct vb_loc = vb.vb_loc; } - and map_bindings rec_flag list = + and map_bindings list = List.map map_binding list and map_case {c_lhs; c_guard; c_rhs} = @@ -113,7 +113,7 @@ module MakeMap(Map : MapArgument) = struct match item.str_desc with Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs) | Tstr_value (rec_flag, list) -> - Tstr_value (rec_flag, map_bindings rec_flag list) + Tstr_value (rec_flag, map_bindings list) | Tstr_primitive vd -> Tstr_primitive (map_value_description vd) | Tstr_type (rf, list) -> @@ -269,7 +269,7 @@ module MakeMap(Map : MapArgument) = struct | Texp_constant _ -> exp.exp_desc | Texp_let (rec_flag, list, exp) -> Texp_let (rec_flag, - map_bindings rec_flag list, + map_bindings list, map_expression exp) | Texp_function (label, cases, partial) -> Texp_function (label, map_cases cases, partial) @@ -354,8 +354,8 @@ module MakeMap(Map : MapArgument) = struct ) | Texp_send (exp, meth, expo) -> Texp_send (map_expression exp, meth, may_map map_expression expo) - | Texp_new (path, lid, cl_decl) -> exp.exp_desc - | Texp_instvar (_, path, _) -> exp.exp_desc + | Texp_new _ -> exp.exp_desc + | Texp_instvar _ -> exp.exp_desc | Texp_setinstvar (path, lid, path2, exp) -> Texp_setinstvar (path, lid, path2, map_expression exp) | Texp_override (path, list) -> @@ -504,8 +504,8 @@ module MakeMap(Map : MapArgument) = struct match cstr with Twith_type decl -> Twith_type (map_type_declaration decl) | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) - | Twith_module (path, lid) -> cstr - | Twith_modsubst (path, lid) -> cstr + | Twith_module _ -> cstr + | Twith_modsubst _ -> cstr in Map.leave_with_constraint cstr @@ -513,7 +513,7 @@ module MakeMap(Map : MapArgument) = struct let mexpr = Map.enter_module_expr mexpr in let mod_desc = match mexpr.mod_desc with - Tmod_ident (p, lid) -> mexpr.mod_desc + Tmod_ident _ -> mexpr.mod_desc | Tmod_structure st -> Tmod_structure (map_structure st) | Tmod_functor (id, name, mtype, mexpr) -> Tmod_functor (id, name, Misc.may_map map_module_type mtype, @@ -552,8 +552,8 @@ module MakeMap(Map : MapArgument) = struct List.map (fun (label, expo) -> (label, may_map map_expression expo) ) args) - | Tcl_let (rec_flat, bindings, ivars, cl) -> - Tcl_let (rec_flat, map_bindings rec_flat bindings, + | Tcl_let (rec_flag, bindings, ivars, cl) -> + Tcl_let (rec_flag, map_bindings bindings, List.map (fun (id, name, exp) -> (id, name, map_expression exp)) ivars, map_class_expr cl) diff --git a/typing/typemod.ml b/typing/typemod.ml index 1ea9bea84..41fca6b0e 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -104,7 +104,7 @@ let rm node = let type_module_type_of_fwd : (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Types.module_type) ref - = ref (fun env m -> assert false) + = ref (fun _env _m -> assert false) (* Merge one "with" constraint in a signature *) @@ -201,7 +201,7 @@ let merge_constraint initial_env loc sg constr = let newdecl = tdecl.typ_type in check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem - | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) + | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) when Ident.name id = s ^ "#row" -> merge env rem namelist (Some id) | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) @@ -234,7 +234,7 @@ let merge_constraint initial_env loc sg constr = update_rec_next rs rem | (Sig_module(id, md, rs) :: rem, s :: namelist, _) when Ident.name id = s -> - let ((path, path_loc, tcstr), newsg) = + let ((path, _path_loc, tcstr), newsg) = merge env (extract_sig env loc md.md_type) namelist None in (path_concat id path, lid, tcstr), Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem @@ -248,7 +248,7 @@ let merge_constraint initial_env loc sg constr = let (tcstr, sg) = merge initial_env sg names None in let sg = match names, constr with - [s], Pwith_typesubst sdecl -> + [_], Pwith_typesubst sdecl -> let id = match !real_id with None -> assert false | Some id -> id in let lid = @@ -271,7 +271,7 @@ let merge_constraint initial_env loc sg constr = in let sub = Subst.add_type id path Subst.identity in Subst.signature sub sg - | [s], Pwith_modsubst (_, lid) -> + | [_], Pwith_modsubst (_, lid) -> let id = match !real_id with None -> assert false | Some id -> id in let path = Typetexp.lookup_module initial_env loc lid.txt in @@ -327,7 +327,7 @@ let map_ext fn exts rem = let rec approx_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> - let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in + let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in Mty_ident path | Pmty_alias lid -> let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in @@ -340,7 +340,7 @@ let rec approx_modtype env smty = Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in let res = approx_modtype newenv sres in Mty_functor(id, arg, res) - | Pmty_with(sbody, constraints) -> + | Pmty_with(sbody, _constraints) -> approx_modtype env sbody | Pmty_typeof smod -> let (_, mty) = !type_module_type_of_fwd env smod in @@ -361,7 +361,7 @@ and approx_sig env ssg = | item :: srem -> match item.psig_desc with | Psig_type (rec_flag, sdecls) -> - let decls = Typedecl.approx_type_decl env sdecls in + let decls = Typedecl.approx_type_decl sdecls in let rem = approx_sig env srem in map_rec_type ~rec_flag (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem @@ -390,7 +390,7 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (path, mty, _od) = type_open env sod in + let (_path, mty, _od) = type_open env sod in approx_sig mty srem | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -483,7 +483,7 @@ let check_sig_item names loc = function let simplify_signature sg = let rec aux = function | [] -> [], StringSet.empty - | (Sig_value(id, descr) as component) :: sg -> + | (Sig_value(id, _descr) as component) :: sg -> let (sg, val_names) as k = aux sg in let name = Ident.name id in if StringSet.mem name val_names then k @@ -498,7 +498,7 @@ let simplify_signature sg = (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = - let (path, info) = Typetexp.find_modtype env loc lid in + let (path, _info) = Typetexp.find_modtype env loc lid in path let transl_module_alias loc env lid = @@ -644,7 +644,7 @@ and transl_signature env sg = (fun pmd -> check_name check_module names pmd.pmd_name) sdecls; let (decls, newenv) = - transl_recmodule_modtypes item.psig_loc env sdecls in + transl_recmodule_modtypes env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_recmodule decls) env loc :: trem, map_rec (fun rs md -> @@ -658,14 +658,14 @@ and transl_signature env sg = | Psig_modtype pmtd -> let newenv, mtd, sg = Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes - (fun () -> transl_modtype_decl names env item.psig_loc pmtd) + (fun () -> transl_modtype_decl names env pmtd) in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env | Psig_open sod -> - let (path, newenv, od) = type_open env sod in + let (_path, newenv, od) = type_open env sod in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_open od) env loc :: trem, rem, final_env @@ -698,11 +698,9 @@ and transl_signature env sg = let (classes, newenv) = Typeclass.class_descriptions env cl in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_class - (List.map2 - (fun pcl tcl -> - let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in - tcl) - cl classes)) env loc + (List.map + (fun (_, _, _, _, _, _, _, _, _, _, _, tcl) -> tcl) + classes)) env loc :: trem, List.flatten (map_rec @@ -719,10 +717,8 @@ and transl_signature env sg = cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in let (trem,rem, final_env) = transl_sig newenv srem in - mksig (Tsig_class_type (List.map2 (fun pcl tcl -> - let (_, _, _, _, _, _, _, tcl) = tcl in - tcl - ) cl classes)) env loc :: trem, + mksig (Tsig_class_type (List.map (fun (_, _, _, _, _, _, _, tcl) -> tcl) classes)) + env loc :: trem, List.flatten (map_rec (fun rs (i, _, d, i', d', i'', d'', _) -> @@ -748,7 +744,7 @@ and transl_signature env sg = ((Cmt_format.Partial_signature sg) :: previous_saved_types); sg -and transl_modtype_decl names env loc +and transl_modtype_decl names env {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = check_name check_modtype names pmtd_name; let tmty = Misc.may_map (transl_modtype env) pmtd_type in @@ -771,7 +767,7 @@ and transl_modtype_decl names env loc in newenv, mtd, Sig_modtype(id, decl) -and transl_recmodule_modtypes loc env sdecls = +and transl_recmodule_modtypes env sdecls = let make_env curr = List.fold_left (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env) @@ -782,7 +778,7 @@ and transl_recmodule_modtypes loc env sdecls = env curr in let transition env_c curr = List.map2 - (fun pmd (id, id_loc, mty) -> + (fun pmd (id, id_loc, _mty) -> let tmty = Builtin_attributes.with_warning_attribute pmd.pmd_attributes (fun () -> transl_modtype env_c pmd.pmd_type) @@ -841,7 +837,7 @@ exception Not_a_path let rec path_of_module mexp = match mexp.mod_desc with Tmod_ident (p,_) -> p - | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors -> + | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> Papply(path_of_module funct, path_of_module arg) | Tmod_constraint (mexp, _, _, _) -> path_of_module mexp @@ -853,8 +849,8 @@ let path_of_module mexp = (* Check that all core type schemes in a structure are closed *) let rec closed_modtype env = function - Mty_ident p -> true - | Mty_alias p -> true + Mty_ident _ -> true + | Mty_alias _ -> true | Mty_signature sg -> let env = Env.add_signature sg env in List.for_all (closed_signature_item env) sg @@ -863,8 +859,8 @@ let rec closed_modtype env = function closed_modtype env body and closed_signature_item env = function - Sig_value(id, desc) -> Ctype.closed_schema env desc.val_type - | Sig_module(id, md, _) -> closed_modtype env md.md_type + Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type + | Sig_module(_id, md, _) -> closed_modtype env md.md_type | _ -> true let check_nongen_scheme env sig_item = @@ -884,7 +880,7 @@ let check_nongen_schemes env sg = let anchor_submodule name anchor = match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos)) -let anchor_recmodule id anchor = +let anchor_recmodule id = Some (Pident id) let enrich_type_decls anchor decls oldenv newenv = @@ -938,7 +934,7 @@ let check_recmodule_inclusion env bindings = (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map - (fun (id, _, mty_decl, modl, mty_actual, _attrs, _loc) -> + (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) -> (id, Ident.rename id, mty_actual)) bindings in (* Enter the Y_i in the environment with their actual types substituted @@ -955,7 +951,7 @@ let check_recmodule_inclusion env bindings = (* Build the output substitution Y_i <- X_i *) let s' = List.fold_left - (fun s (id, id', mty_actual) -> + (fun s (id, id', _mty_actual) -> Subst.add_module id (Pident id') s) Subst.identity bindings1 in (* Recurse with env' and s' *) @@ -1037,14 +1033,14 @@ let modtype_of_package env loc p nl tl = let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = let mkmty p nl tl = let ntl = - List.filter (fun (n,t) -> Ctype.free_variables t = []) + List.filter (fun (_n,t) -> Ctype.free_variables t = []) (List.combine nl tl) in let (nl, tl) = List.split ntl in modtype_of_package env Location.none p nl tl in let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in try Includemod.modtypes env mty1 mty2 = Tcoerce_none - with Includemod.Error msg -> false + with Includemod.Error _msg -> false (* raise(Error(Location.none, env, Not_included msg)) *) let () = Ctype.package_subtype := package_subtype @@ -1090,7 +1086,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = { md with mod_type = mty } in rm md | Pmod_structure sstr -> - let (str, sg, finalenv) = + let (str, sg, _finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in let md = rm { mod_desc = Tmod_structure str; @@ -1316,8 +1312,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (fun (name, _, _, _, _) -> check_name check_module names name) sbind; let (decls, newenv) = - transl_recmodule_modtypes loc env - (List.map (fun (name, smty, smodl, attrs, loc) -> + transl_recmodule_modtypes env + (List.map (fun (name, smty, _smodl, attrs, loc) -> {pmd_name=name; pmd_type=smty; pmd_attributes=attrs; pmd_loc=loc}) sbind ) in @@ -1327,7 +1323,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let modl = Builtin_attributes.with_warning_attribute attrs (fun () -> - type_module true funct_body (anchor_recmodule id anchor) + type_module true funct_body (anchor_recmodule id) newenv smodl ) in @@ -1365,11 +1361,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (* check that it is non-abstract *) let newenv, mtd, sg = Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes - (fun () -> transl_modtype_decl names env loc pmtd) + (fun () -> transl_modtype_decl names env pmtd) in Tstr_modtype mtd, [sg], newenv | Pstr_open sod -> - let (path, newenv, od) = type_open ~toplevel env sod in + let (_path, newenv, od) = type_open ~toplevel env sod in Tstr_open od, [], newenv | Pstr_class cl -> List.iter @@ -1401,7 +1397,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in Tstr_class_type - (List.map (fun (i, i_loc, d, _, _, _, _, c) -> + (List.map (fun (i, i_loc, _, _, _, _, _, c) -> (i, i_loc, c)) classes), (* TODO: check with Jacques why this is here Tstr_type @@ -1480,16 +1476,16 @@ let type_structure = type_structure false None (* Normalize types in a signature *) let rec normalize_modtype env = function - Mty_ident p -> () - | Mty_alias p -> () + Mty_ident _ + | Mty_alias _ -> () | Mty_signature sg -> normalize_signature env sg - | Mty_functor(id, param, body) -> normalize_modtype env body + | Mty_functor(_id, _param, body) -> normalize_modtype env body and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function - Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type - | Sig_module(id, md, _) -> normalize_modtype env md.md_type + Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type + | Sig_module(_id, md, _) -> normalize_modtype env md.md_type | _ -> () (* Extract the module type of a module expression *) @@ -1515,7 +1511,7 @@ let type_module_type_of env smod = (* For Typecore *) -let type_package env m p nl tl = +let type_package env m p nl = (* Same as Pexp_letmodule *) (* remember original level *) let lv = Ctype.get_current_level () in @@ -1528,7 +1524,7 @@ let type_package env m p nl tl = let (mp, env) = match modl.mod_desc with Tmod_ident (mp,_) -> (mp, env) - | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, mty, Tmodtype_implicit, _) + | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) -> (mp, env) (* PR#6982 *) | _ -> let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in @@ -1698,7 +1694,7 @@ let package_units initial_env objfiles cmifile modulename = let unit_names = List.map fst units in let imports = List.filter - (fun (name, crc) -> not (List.mem name unit_names)) + (fun (name, _crc) -> not (List.mem name unit_names)) (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 017197392..063185510 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -73,7 +73,7 @@ let instance_list = Ctype.instance_list Env.empty let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = fun env loc lid make_error -> let check_module mlid = - try ignore (Env.lookup_module true mlid env) with + try ignore (Env.lookup_module ~load:true mlid env) with | Not_found -> narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) | Env.Recmodule -> @@ -83,7 +83,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = | Longident.Lident _ -> () | Longident.Ldot (mlid, _) -> check_module mlid; - let md = Env.find_module (Env.lookup_module true mlid env) env in + let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in begin match Env.scrape_alias env md.md_type with | Mty_functor _ -> raise (Error (loc, env, Access_functor_as_structure mlid)) @@ -93,7 +93,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = end | Longident.Lapply (flid, mlid) -> check_module flid; - let fmd = Env.find_module (Env.lookup_module true flid env) env in + let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in begin match Env.scrape_alias env fmd.md_type with | Mty_signature _ -> raise (Error (loc, env, Apply_structure_as_functor flid)) @@ -101,7 +101,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = raise (Error (loc, env, Cannot_scrape_alias(flid, p))) | _ -> () end; - let mmd = Env.find_module (Env.lookup_module true mlid env) env in + let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in check_module mlid; begin match Env.scrape_alias env mmd.md_type with | Mty_alias p -> @@ -199,7 +199,7 @@ let transl_modtype = ref (fun _ -> assert false) let create_package_mty fake loc env (p, l) = let l = List.sort - (fun (s1, t1) (s2, t2) -> + (fun (s1, _t1) (s2, _t2) -> if s1.txt = s2.txt then raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); compare s1.txt s2.txt) @@ -379,7 +379,7 @@ let rec transl_type env policy styp = let ty = newobj (transl_fields loc env policy [] o fields) in ctyp (Ttyp_object (fields, o)) ty | Ptyp_class(lid, stl) -> - let (path, decl, is_variant) = + let (path, decl, _is_variant) = try let (path, decl) = Env.lookup_type lid.txt env in let rec check decl = @@ -509,7 +509,7 @@ let rec transl_type env policy styp = let ty = mkfield l f and ty' = mkfield l f' in if equal env false [ty] [ty'] then () else try unify env ty ty' - with Unify trace -> + with Unify _trace -> raise(Error(loc, env, Constructor_mismatch (ty,ty'))) with Not_found -> Hashtbl.add hfields h (l,f) @@ -632,7 +632,7 @@ let rec transl_type env policy styp = ) l in let path = !transl_modtype_longident styp.ptyp_loc env p.txt in let ty = newty (Tpackage (path, - List.map (fun (s, pty) -> s.txt) l, + List.map (fun (s, _pty) -> s.txt) l, List.map (fun (_,cty) -> cty.ctyp_type) ptys)) in ctyp (Ttyp_package { @@ -673,7 +673,7 @@ let rec make_fixed_univars ty = {row with row_fixed=true; row_fields = List.map (fun (s,f as p) -> match Btype.row_field_repr f with - Reither (c, tl, m, r) -> s, Reither (c, tl, true, r) + Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r) | _ -> p) row.row_fields}; Btype.iter_row make_fixed_univars row diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 4dea4852e..087c297eb 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -750,7 +750,7 @@ let class_field sub cf = in Cf.mk ~loc ~attrs desc -let location sub l = l +let location _sub l = l let default_mapper = { diff --git a/utils/arg_helper.ml b/utils/arg_helper.ml index 15061e33d..24193d221 100644 --- a/utils/arg_helper.ml +++ b/utils/arg_helper.ml @@ -58,11 +58,6 @@ end) = struct let add_user_override key value t = { t with user_override = S.Key.Map.add key value t.user_override } - let no_equals value = - match String.index value '=' with - | exception Not_found -> true - | _index -> false - exception Parse_failure of exn let parse_exn str ~update = @@ -101,7 +96,7 @@ end) = struct in update := parsed - let parse str ~help_text ~update = + let parse str help_text update = match parse_exn str ~update with | () -> () | exception (Parse_failure exn) -> @@ -111,7 +106,7 @@ end) = struct | Ok | Parse_failed of exn - let parse_no_error str ~update = + let parse_no_error str update = match parse_exn str ~update with | () -> Ok | exception (Parse_failure exn) -> Parse_failed exn diff --git a/utils/arg_helper.mli b/utils/arg_helper.mli index d877d755b..fba7aa218 100644 --- a/utils/arg_helper.mli +++ b/utils/arg_helper.mli @@ -51,13 +51,13 @@ end) : sig val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed - val parse : string -> help_text:string -> update:parsed ref -> unit + val parse : string -> string -> parsed ref -> unit type parse_result = | Ok | Parse_failed of exn - val parse_no_error : string -> update:parsed ref -> parse_result + val parse_no_error : string -> parsed ref -> parse_result val get : key:S.Key.t -> parsed -> S.Value.t end diff --git a/utils/clflags.mli b/utils/clflags.mli index a5c9ec9bd..4c1383460 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -17,12 +17,12 @@ module Int_arg_helper : sig type parsed - val parse : string -> help_text:string -> update:parsed ref -> unit + val parse : string -> string -> parsed ref -> unit type parse_result = | Ok | Parse_failed of exn - val parse_no_error : string -> update:parsed ref -> parse_result + val parse_no_error : string -> parsed ref -> parse_result val get : key:int -> parsed -> int end @@ -31,12 +31,12 @@ end module Float_arg_helper : sig type parsed - val parse : string -> help_text:string -> update:parsed ref -> unit + val parse : string -> string -> parsed ref -> unit type parse_result = | Ok | Parse_failed of exn - val parse_no_error : string -> update:parsed ref -> parse_result + val parse_no_error : string -> parsed ref -> parse_result val get : key:int -> parsed -> float end diff --git a/utils/consistbl.ml b/utils/consistbl.ml index b9be8ecac..dbba5d1f5 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -57,7 +57,7 @@ let extract l tbl = let filter p tbl = let to_remove = ref [] in Hashtbl.iter - (fun name (crc, auth) -> + (fun name _ -> if not (p name) then to_remove := name :: !to_remove) tbl; List.iter diff --git a/utils/identifiable.ml b/utils/identifiable.ml index 4ff649af7..53f533d04 100644 --- a/utils/identifiable.ml +++ b/utils/identifiable.ml @@ -66,7 +66,7 @@ module Make_map (T : Thing) = struct m1 m2 let union_right m1 m2 = - merge (fun id x y -> match x, y with + merge (fun _id x y -> match x, y with | None, None -> None | None, Some v | Some v, None diff --git a/utils/misc.ml b/utils/misc.ml index cf75391d6..af8ffbdff 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -108,7 +108,7 @@ module Stdlib = struct let rec aux acc l1 l2 = match l1, l2 with | [], _ -> (List.rev acc, l2) - | h::t, [] -> raise (Invalid_argument "map2_prefix") + | _ :: _, [] -> raise (Invalid_argument "map2_prefix") | h1::t1, h2::t2 -> let h = f h1 h2 in aux (h :: acc) t1 t2 @@ -232,7 +232,7 @@ let remove_file filename = try if Sys.file_exists filename then Sys.remove filename - with Sys_error msg -> + with Sys_error _msg -> () (* Expand a -I option: if it starts with +, make it relative to the standard @@ -676,7 +676,7 @@ let delete_eol_spaces src = | '\n' -> Bytes.set dst i_dst '\n'; loop (i_src + 1) (i_dst + 1) - | c -> + | _ -> for n = 0 to spaces do Bytes.set dst (i_dst + n) src.[i_src - spaces + n] done; diff --git a/utils/strongly_connected_components.ml b/utils/strongly_connected_components.ml index ba9b45467..a11f6987f 100644 --- a/utils/strongly_connected_components.ml +++ b/utils/strongly_connected_components.ml @@ -131,7 +131,8 @@ module Make (Id : Identifiable.S) = struct | No_loop of Id.t (* Ensure that the dependency graph does not have external dependencies. *) - let check dependencies = + (* Note: this function is currently not used. *) + let _check dependencies = Id.Map.iter (fun id set -> Id.Set.iter (fun v -> if not (Id.Map.mem v dependencies) diff --git a/utils/tbl.ml b/utils/tbl.ml index 4b03fe625..abb7309b9 100644 --- a/utils/tbl.ml +++ b/utils/tbl.ml @@ -68,7 +68,7 @@ let rec find x = function let rec mem x = function Empty -> false - | Node(l, v, d, r, _) -> + | Node(l, v, _d, r, _) -> let c = compare x v in c = 0 || mem x (if c < 0 then l else r) @@ -76,13 +76,13 @@ let rec merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t - | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) -> + | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) -> bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) let rec remove x = function Empty -> Empty - | Node(l, v, d, r, h) -> + | Node(l, v, d, r, _h) -> let c = compare x v in if c = 0 then merge l r diff --git a/utils/warnings.ml b/utils/warnings.ml index af0a29d50..c7165988b 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -239,7 +239,7 @@ let parse_opt error active flags s = | '+' -> loop_letter_num set (i+1) | '-' -> loop_letter_num clear (i+1) | '@' -> loop_letter_num set_all (i+1) - | c -> error () + | _ -> error () and loop_letter_num myset i = if i >= String.length s then error () else match s.[i] with @@ -395,7 +395,7 @@ let message = function s ^ " belongs to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Please disambiguate if this is wrong." | Ambiguous_name (_, _, false) -> assert false - | Ambiguous_name (slist, tl, true) -> + | Ambiguous_name (_slist, tl, true) -> "these field labels belong to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Please disambiguate if this is wrong."