ocaml-base-compiler.4.10.0/typing/typecore.ml

1

(**************************************************************************)

2

(* *)

3

(* OCaml *)

4

(* *)

5

(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)

6

(* *)

7

8

(* en Automatique. *)

9

(* *)

10

11

(* the GNU Lesser General Public License version 2.1, with the *)

12

(* special exception on linking described in the file LICENSE. *)

13

(* *)

14

(**************************************************************************)

15

16

(* Typechecking for the core language *)

17

18

open Misc

19

open Asttypes

20

open Parsetree

21

open Types

22

open Typedtree

23

open Btype

24

open Ctype

25

26

type type_forcing_context =

27

| If_conditional

28

| If_no_else_branch

29

| While_loop_conditional

30

| While_loop_body

31

| For_loop_start_index

32

| For_loop_stop_index

33

| For_loop_body

34

| Assert_condition

35

| Sequence_left_hand_side

36

| When_guard

37

38

type type_expected = {

39

ty: type_expr;

40

explanation: type_forcing_context option;

41

}

42

43

type existential_restriction =

44

| At_toplevel (** no existential types at the toplevel *)

45

| In_group (** nor with let ... and ... *)

46

| In_rec (** or recursive definition *)

47

| With_attributes (** or let[@any_attribute] = ... *)

48

| In_class_args (** or in class arguments *)

49

| In_class_def (** or in [class c = let ... in ...] *)

50

| In_self_pattern (** or in self pattern *)

51

52

type error =

53

| Constructor_arity_mismatch of Longident.t * int * int

54

| Label_mismatch of Longident.t * Ctype.Unification_trace.t

55

| Pattern_type_clash of Ctype.Unification_trace.t * pattern_desc option

56

| Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t

57

| Multiply_bound_variable of string

58

| Orpat_vars of Ident.t * Ident.t list

59

| Expr_type_clash of

60

Ctype.Unification_trace.t * type_forcing_context option

61

* expression_desc option

62

| Apply_non_function of type_expr

63

| Apply_wrong_label of arg_label * type_expr

64

| Label_multiply_defined of string

65

| Label_missing of Ident.t list

66

| Label_not_mutable of Longident.t

67

| Wrong_name of

68

string * type_expected * string * Path.t * string * string list

69

| Name_type_mismatch of

70

string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list

71

| Invalid_format of string

72

| Undefined_method of type_expr * string * string list option

73

| Undefined_inherited_method of string * string list

74

| Virtual_class of Longident.t

75

| Private_type of type_expr

76

| Private_label of Longident.t * type_expr

77

| Private_constructor of constructor_description * type_expr

78

| Unbound_instance_variable of string * string list

79

| Instance_variable_not_mutable of string

80

| Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t

81

| Outside_class

82

| Value_multiply_overridden of string

83

| Coercion_failure of

84

type_expr * type_expr * Ctype.Unification_trace.t * bool

85

| Too_many_arguments of bool * type_expr * type_forcing_context option

86

| Abstract_wrong_label of arg_label * type_expr * type_forcing_context option

87

| Scoping_let_module of string * type_expr

88

| Not_a_variant_type of Longident.t

89

| Incoherent_label_order

90

| Less_general of string * Ctype.Unification_trace.t

91

| Modules_not_allowed

92

| Cannot_infer_signature

93

| Not_a_packed_module of type_expr

94

| Unexpected_existential of existential_restriction * string * string list

95

| Invalid_interval

96

| Invalid_for_loop_index

97

| No_value_clauses

98

| Exception_pattern_disallowed

99

| Mixed_value_and_exception_patterns_under_guard

100

| Inlined_record_escape

101

| Inlined_record_expected

102

| Unrefuted_pattern of pattern

103

| Invalid_extension_constructor_payload

104

| Not_an_extension_constructor

105

| Literal_overflow of string

106

| Unknown_literal of string * char

107

| Illegal_letrec_pat

108

| Illegal_letrec_expr

109

| Illegal_class_expr

110

| Empty_pattern

111

| Letop_type_clash of string * Ctype.Unification_trace.t

112

| Andop_type_clash of string * Ctype.Unification_trace.t

113

| Bindings_type_clash of Ctype.Unification_trace.t

114

115

exception Error of Location.t * Env.t * error

116

exception Error_forward of Location.error

117

118

(* Forward declaration, to be filled in by Typemod.type_module *)

119

120

let type_module =

121

ref ((fun _env _md -> assert false) :

122

Env.t -> Parsetree.module_expr -> Typedtree.module_expr)

123

124

(* Forward declaration, to be filled in by Typemod.type_open *)

125

126

let type_open :

127

(?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->

128

Longident.t loc -> Path.t * Env.t)

129

ref =

130

ref (fun ?used_slot:_ _ -> assert false)

131

132

let type_open_decl :

133

(?used_slot:bool ref -> Env.t -> Parsetree.open_declaration

134

-> open_declaration * Types.signature * Env.t)

135

ref =

136

ref (fun ?used_slot:_ _ -> assert false)

137

138

(* Forward declaration, to be filled in by Typemod.type_package *)

139

140

let type_package =

141

ref (fun _ -> assert false)

142

143

(* Forward declaration, to be filled in by Typeclass.class_structure *)

144

let type_object =

145

ref (fun _env _s -> assert false :

146

Env.t -> Location.t -> Parsetree.class_structure ->

147

Typedtree.class_structure * Types.class_signature * string list)

148

149

(*

150

Saving and outputting type information.

151

We keep these function names short, because they have to be

152

called each time we create a record of type [Typedtree.expression]

153

or [Typedtree.pattern] that will end up in the typed AST.

154

*)

155

let re node =

156

Cmt_format.add_saved_type (Cmt_format.Partial_expression node);

157

Stypes.record (Stypes.Ti_expr node);

158

node

159

;;

160

let rp node =

161

Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);

162

Stypes.record (Stypes.Ti_pat node);

163

node

164

;;

165

166

167

type recarg =

168

| Allowed

169

| Required

170

| Rejected

171

172

173

let mk_expected ?explanation ty = { ty; explanation; }

174

175

let case lhs rhs =

176

{c_lhs = lhs; c_guard = None; c_rhs = rhs}

177

178

(* Typing of constants *)

179

180

let type_constant = function

181

Const_int _ -> instance Predef.type_int

182

| Const_char _ -> instance Predef.type_char

183

| Const_string _ -> instance Predef.type_string

184

| Const_float _ -> instance Predef.type_float

185

| Const_int32 _ -> instance Predef.type_int32

186

| Const_int64 _ -> instance Predef.type_int64

187

| Const_nativeint _ -> instance Predef.type_nativeint

188

189

let constant : Parsetree.constant -> (Asttypes.constant, error) result =

190

function

191

| Pconst_integer (i,None) ->

192

begin

193

try Ok (Const_int (Misc.Int_literal_converter.int i))

194

with Failure _ -> Error (Literal_overflow "int")

195

end

196

| Pconst_integer (i,Some 'l') ->

197

begin

198

try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))

199

with Failure _ -> Error (Literal_overflow "int32")

200

end

201

| Pconst_integer (i,Some 'L') ->

202

begin

203

try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))

204

with Failure _ -> Error (Literal_overflow "int64")

205

end

206

| Pconst_integer (i,Some 'n') ->

207

begin

208

try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))

209

with Failure _ -> Error (Literal_overflow "nativeint")

210

end

211

| Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))

212

| Pconst_char c -> Ok (Const_char c)

213

| Pconst_string (s,d) -> Ok (Const_string (s,d))

214

| Pconst_float (f,None)-> Ok (Const_float f)

215

| Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))

216

217

let constant_or_raise env loc cst =

218

match constant cst with

219

| Ok c -> c

220

| Error err -> raise (Error (loc, env, err))

221

222

(* Specific version of type_option, using newty rather than newgenty *)

223

224

let type_option ty =

225

newty (Tconstr(Predef.path_option,[ty], ref Mnil))

226

227

let mkexp exp_desc exp_type exp_loc exp_env =

228

{ exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }

229

230

let option_none env ty loc =

231

let lid = Longident.Lident "None" in

232

let cnone = Env.find_ident_constructor Predef.ident_none env in

233

mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env

234

235

let option_some env texp =

236

let lid = Longident.Lident "Some" in

237

let csome = Env.find_ident_constructor Predef.ident_some env in

238

mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )

239

(type_option texp.exp_type) texp.exp_loc texp.exp_env

240

241

let extract_option_type env ty =

242

match expand_head env ty with {desc = Tconstr(path, [ty], _)}

243

when Path.same path Predef.path_option -> ty

244

| _ -> assert false

245

246

let extract_concrete_record env ty =

247

match extract_concrete_typedecl env ty with

248

(p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)

249

| _ -> raise Not_found

250

251

let extract_concrete_variant env ty =

252

match extract_concrete_typedecl env ty with

253

(p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)

254

| (p0, p, {type_kind=Type_open}) -> (p0, p, [])

255

| _ -> raise Not_found

256

257

let extract_label_names env ty =

258

try

259

let (_, _,fields) = extract_concrete_record env ty in

260

List.map (fun l -> l.Types.ld_id) fields

261

with Not_found ->

262

assert false

263

264

(* Typing of patterns *)

265

266

(* unification inside type_exp and type_expect *)

267

let unify_exp_types loc env ty expected_ty =

268

(* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type

269

Printtyp.raw_type_expr expected_ty; *)

270

try

271

unify env ty expected_ty

272

with

273

Unify trace ->

274

raise(Error(loc, env, Expr_type_clash(trace, None, None)))

275

| Tags(l1,l2) ->

276

raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))

277

278

(* level at which to create the local type declarations *)

279

let gadt_equations_level = ref None

280

let get_gadt_equations_level () =

281

match !gadt_equations_level with

282

Some y -> y

283

| None -> assert false

284

285

(* unification inside type_pat*)

286

let unify_pat_types ?(refine=false) loc env ty ty' =

287

try

288

if refine then

289

unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty'

290

else

291

unify !env ty ty'

292

with

293

| Unify trace ->

294

raise(Error(loc, !env, Pattern_type_clash(trace, None)))

295

| Tags(l1,l2) ->

296

raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))

297

298

let unify_pat ?refine env pat expected_ty =

299

try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty

300

with Error (loc, env, Pattern_type_clash(trace, None)) ->

301

raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))

302

303

(* Creating new conjunctive types is not allowed when typing patterns *)

304

(* make all Reither present in open variants *)

305

let finalize_variant pat =

306

match pat.pat_desc with

307

Tpat_variant(tag, opat, r) ->

308

let row =

309

match expand_head pat.pat_env pat.pat_type with

310

{desc = Tvariant row} -> r := row; row_repr row

311

| _ -> assert false

312

in

313

begin match row_field tag row with

314

| Rabsent -> () (* assert false *)

315

| Reither (true, [], _, e) when not row.row_closed ->

316

set_row_field e (Rpresent None)

317

| Reither (false, ty::tl, _, e) when not row.row_closed ->

318

set_row_field e (Rpresent (Some ty));

319

begin match opat with None -> assert false

320

| Some pat ->

321

let env = ref pat.pat_env in

322

List.iter (unify_pat env pat) (ty::tl)

323

end

324

| Reither (c, _l, true, e) when not (row_fixed row) ->

325

set_row_field e (Reither (c, [], false, ref None))

326

| _ -> ()

327

end;

328

(* Force check of well-formedness WHY? *)

329

(* unify_pat pat.pat_env pat

330

(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;

331

row_bound=(); row_fixed=false; row_name=None})); *)

332

| _ -> ()

333

334

let has_variants p =

335

exists_pattern

336

(function {pat_desc=Tpat_variant _} -> true | _ -> false)

337

p

338

339

(* pattern environment *)

340

type pattern_variable =

341

{

342

pv_id: Ident.t;

343

pv_type: type_expr;

344

pv_loc: Location.t;

345

pv_as_var: bool;

346

pv_attributes: attributes;

347

}

348

349

type module_variable =

350

string loc * Location.t

351

352

let pattern_variables = ref ([] : pattern_variable list)

353

let pattern_force = ref ([] : (unit -> unit) list)

354

let pattern_scope = ref (None : Annot.ident option);;

355

let allow_modules = ref false

356

let module_variables = ref ([] : module_variable list)

357

let reset_pattern scope allow =

358

pattern_variables := [];

359

pattern_force := [];

360

pattern_scope := scope;

361

allow_modules := allow;

362

module_variables := [];

363

;;

364

365

let maybe_add_pattern_variables_ghost loc_let env pv =

366

List.fold_right

367

(fun {pv_id; _} env ->

368

let name = Ident.name pv_id in

369

if Env.bound_value name env then env

370

else begin

371

Env.enter_unbound_value name

372

(Val_unbound_ghost_recursive loc_let) env

373

end

374

) pv env

375

376

let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty

377

attrs =

378

if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)

379

!pattern_variables

380

then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));

381

let id = Ident.create_local name.txt in

382

pattern_variables :=

383

{pv_id = id;

384

pv_type = ty;

385

pv_loc = loc;

386

pv_as_var = is_as_variable;

387

pv_attributes = attrs} :: !pattern_variables;

388

if is_module then begin

389

(* Note: unpack patterns enter a variable of the same name *)

390

if not !allow_modules then

391

raise (Error (loc, Env.empty, Modules_not_allowed));

392

module_variables := (name, loc) :: !module_variables

393

end else begin

394

(* moved to genannot *)

395

Option.iter

396

(fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))

397

!pattern_scope

398

end;

399

id

400

401

let sort_pattern_variables vs =

402

List.sort

403

(fun {pv_id = x; _} {pv_id = y; _} ->

404

Stdlib.compare (Ident.name x) (Ident.name y))

405

vs

406

407

let enter_orpat_variables loc env p1_vs p2_vs =

408

(* unify_vars operate on sorted lists *)

409

410

let p1_vs = sort_pattern_variables p1_vs

411

and p2_vs = sort_pattern_variables p2_vs in

412

413

let rec unify_vars p1_vs p2_vs =

414

let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in

415

match p1_vs, p2_vs with

416

| {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2

417

when Ident.equal x1 x2 ->

418

if x1==x2 then

419

unify_vars rem1 rem2

420

else begin

421

begin try

422

unify_var env (newvar ()) t1;

423

unify env t1 t2

424

with

425

| Unify trace ->

426

raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))

427

end;

428

(x2,x1)::unify_vars rem1 rem2

429

end

430

| [],[] -> []

431

| {pv_id; _}::_, [] | [],{pv_id; _}::_ ->

432

raise (Error (loc, env, Orpat_vars (pv_id, [])))

433

| {pv_id = x; _}::_, {pv_id = y; _}::_ ->

434

let err =

435

if Ident.name x < Ident.name y

436

then Orpat_vars (x, vars p2_vs)

437

else Orpat_vars (y, vars p1_vs) in

438

raise (Error (loc, env, err)) in

439

unify_vars p1_vs p2_vs

440

441

let rec build_as_type env p =

442

match p.pat_desc with

443

Tpat_alias(p1,_, _) -> build_as_type env p1

444

| Tpat_tuple pl ->

445

let tyl = List.map (build_as_type env) pl in

446

newty (Ttuple tyl)

447

| Tpat_construct(_, cstr, pl) ->

448

let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in

449

if keep then p.pat_type else

450

let tyl = List.map (build_as_type env) pl in

451

let ty_args, ty_res = instance_constructor cstr in

452

List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})

453

(List.combine pl tyl) ty_args;

454

ty_res

455

| Tpat_variant(l, p', _) ->

456

let ty = Option.map (build_as_type env) p' in

457

newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();

458

row_bound=(); row_name=None;

459

row_fixed=None; row_closed=false})

460

| Tpat_record (lpl,_) ->

461

let lbl = snd3 (List.hd lpl) in

462

if lbl.lbl_private = Private then p.pat_type else

463

let ty = newvar () in

464

let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in

465

let do_label lbl =

466

let _, ty_arg, ty_res = instance_label false lbl in

467

unify_pat env {p with pat_type = ty} ty_res;

468

let refinable =

469

lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&

470

match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in

471

if refinable then begin

472

let arg = List.assoc lbl.lbl_pos ppl in

473

unify_pat env {arg with pat_type = build_as_type env arg} ty_arg

474

end else begin

475

let _, ty_arg', ty_res' = instance_label false lbl in

476

unify !env ty_arg ty_arg';

477

unify_pat env p ty_res'

478

end in

479

Array.iter do_label lbl.lbl_all;

480

ty

481

| Tpat_or(p1, p2, row) ->

482

begin match row with

483

None ->

484

let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in

485

unify_pat env {p2 with pat_type = ty2} ty1;

486

ty1

487

| Some row ->

488

let row = row_repr row in

489

newty (Tvariant{row with row_closed=false; row_more=newvar()})

490

end

491

| Tpat_any | Tpat_var _ | Tpat_constant _

492

| Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type

493

494

let build_or_pat env loc lid =

495

let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in

496

let tyl = List.map (fun _ -> newvar()) decl.type_params in

497

let row0 =

498

let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in

499

match ty.desc with

500

Tvariant row when static_row row -> row

501

| _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))

502

in

503

let pats, fields =

504

List.fold_left

505

(fun (pats,fields) (l,f) ->

506

match row_field_repr f with

507

Rpresent None ->

508

(l,None) :: pats,

509

(l, Reither(true,[], true, ref None)) :: fields

510

| Rpresent (Some ty) ->

511

(l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;

512

pat_type=ty; pat_extra=[]; pat_attributes=[]})

513

:: pats,

514

(l, Reither(false, [ty], true, ref None)) :: fields

515

| _ -> pats, fields)

516

([],[]) (row_repr row0).row_fields in

517

let row =

518

{ row_fields = List.rev fields; row_more = newvar(); row_bound = ();

519

row_closed = false; row_fixed = None; row_name = Some (path, tyl) }

520

in

521

let ty = newty (Tvariant row) in

522

let gloc = {loc with Location.loc_ghost=true} in

523

let row' = ref {row with row_more=newvar()} in

524

let pats =

525

List.map

526

(fun (l,p) ->

527

{pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;

528

pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})

529

pats

530

in

531

match pats with

532

[] ->

533

(* empty polymorphic variants: not possible with the concrete language

534

but valid at the ast level *)

535

raise(Error(lid.loc, env, Not_a_variant_type lid.txt))

536

| pat :: pats ->

537

let r =

538

List.fold_left

539

(fun pat pat0 ->

540

{pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];

541

pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})

542

pat pats in

543

(path, rp { r with pat_loc = loc },ty)

544

545

let split_cases env cases =

546

let add_case lst case = function

547

| None -> lst

548

| Some c_lhs -> { case with c_lhs } :: lst

549

in

550

List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->

551

match split_pattern c_lhs with

552

| Some _, Some _ when c_guard <> None ->

553

raise (Error (c_lhs.pat_loc, env,

554

Mixed_value_and_exception_patterns_under_guard))

555

| vp, ep -> add_case vals case vp, add_case exns case ep

556

) cases ([], [])

557

558

(* Type paths *)

559

560

let rec expand_path env p =

561

let decl =

562

try Some (Env.find_type p env) with Not_found -> None

563

in

564

match decl with

565

Some {type_manifest = Some ty} ->

566

begin match repr ty with

567

{desc=Tconstr(p,_,_)} -> expand_path env p

568

| _ -> assert false

569

end

570

| _ ->

571

let p' = Env.normalize_type_path None env p in

572

if Path.same p p' then p else expand_path env p'

573

574

let compare_type_path env tpath1 tpath2 =

575

Path.same (expand_path env tpath1) (expand_path env tpath2)

576

577

(* Records *)

578

let label_of_kind kind =

579

if kind = "record" then "field" else "constructor"

580

581

module NameChoice(Name : sig

582

type t

583

type usage

584

val type_kind: string

585

val get_name: t -> string

586

val get_type: t -> type_expr

587

val lookup_all_from_type:

588

Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list

589

val in_env: t -> bool

590

end) = struct

591

open Name

592

593

let get_type_path d =

594

match (repr (get_type d)).desc with

595

| Tconstr(p, _, _) -> p

596

| _ -> assert false

597

598

let lookup_from_type env tpath usage lid =

599

let descrs = lookup_all_from_type lid.loc usage tpath env in

600

match lid.txt with

601

| Longident.Lident s -> begin

602

match

603

List.find (fun (nd, _) -> get_name nd = s) descrs

604

with

605

| descr, use ->

606

use ();

607

descr

608

| exception Not_found ->

609

let names = List.map (fun (nd, _) -> get_name nd) descrs in

610

raise (Error (lid.loc, env,

611

Wrong_name ("", mk_expected (newvar ()),

612

type_kind, tpath, s, names)))

613

end

614

| _ -> raise Not_found

615

616

let rec unique eq acc = function

617

[] -> List.rev acc

618

| x :: rem ->

619

if List.exists (eq x) acc then unique eq acc rem

620

else unique eq (x :: acc) rem

621

622

let ambiguous_types env lbl others =

623

let tpath = get_type_path lbl in

624

let others =

625

List.map (fun (lbl, _) -> get_type_path lbl) others in

626

let tpaths = unique (compare_type_path env) [tpath] others in

627

match tpaths with

628

[_] -> []

629

| _ -> let open Printtyp in

630

wrap_printing_env ~error:true env (fun () ->

631

reset(); strings_of_paths Type tpaths)

632

633

let disambiguate_by_type env tpath lbls =

634

match lbls with

635

| (Error _ : _ result) -> raise Not_found

636

| Ok lbls ->

637

let check_type (lbl, _) =

638

let lbl_tpath = get_type_path lbl in

639

compare_type_path env tpath lbl_tpath

640

in

641

List.find check_type lbls

642

643

let disambiguate ?(warn=Location.prerr_warning) ?scope

644

usage lid env opath lbls =

645

let scope = match scope with None -> lbls | Some l -> l in

646

let lbl = match opath with

647

None ->

648

begin match lbls with

649

| (Error(loc', env', err) : _ result) ->

650

Env.lookup_error loc' env' err

651

| Ok [] -> assert false

652

| Ok((lbl, use) :: rest) ->

653

use ();

654

Printtyp.Conflicts.reset ();

655

let paths = ambiguous_types env lbl rest in

656

let expansion =

657

Format.asprintf "%t" Printtyp.Conflicts.print_explanations in

658

if paths <> [] then

659

warn lid.loc

660

(Warnings.Ambiguous_name ([Longident.last lid.txt],

661

paths, false, expansion));

662

lbl

663

end

664

| Some(tpath0, tpath, pr) ->

665

let warn_pr () =

666

let label = label_of_kind type_kind in

667

warn lid.loc

668

(Warnings.Not_principal

669

("this type-based " ^ label ^ " disambiguation"))

670

in

671

try

672

let lbl, use = disambiguate_by_type env tpath scope in

673

use ();

674

if not pr then begin

675

(* Check if non-principal type is affecting result *)

676

match lbls with

677

| (Error _ : _ result) | Ok [] -> warn_pr ()

678

| Ok ((lbl', _use') :: rest) ->

679

let lbl_tpath = get_type_path lbl' in

680

if not (compare_type_path env tpath lbl_tpath) then warn_pr ()

681

else

682

Printtyp.Conflicts.reset ();

683

let paths = ambiguous_types env lbl rest in

684

let expansion =

685

Format.asprintf "%t"

686

Printtyp.Conflicts.print_explanations in

687

if paths <> [] then

688

warn lid.loc

689

(Warnings.Ambiguous_name ([Longident.last lid.txt],

690

paths, false, expansion))

691

end;

692

lbl

693

with Not_found -> try

694

let lbl = lookup_from_type env tpath usage lid in

695

if in_env lbl then

696

begin

697

let s =

698

Printtyp.wrap_printing_env ~error:true env

699

(fun () -> Printtyp.string_of_path tpath) in

700

warn lid.loc

701

(Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));

702

end;

703

if not pr then warn_pr ();

704

lbl

705

with Not_found ->

706

match lbls with

707

| (Error(loc', env', err) : _ result) ->

708

Env.lookup_error loc' env' err

709

| Ok lbls ->

710

let tp = (tpath0, expand_path env tpath) in

711

let tpl =

712

List.map

713

(fun (lbl, _) ->

714

let tp0 = get_type_path lbl in

715

let tp = expand_path env tp0 in

716

(tp0, tp))

717

lbls

718

in

719

raise (Error (lid.loc, env,

720

Name_type_mismatch (type_kind, lid.txt, tp, tpl)))

721

in

722

if in_env lbl then

723

begin match scope with

724

| Ok ((lab1,_)::_) when lab1 == lbl -> ()

725

| _ ->

726

Location.prerr_warning lid.loc

727

(Warnings.Disambiguated_name(get_name lbl))

728

end;

729

lbl

730

end

731

732

let wrap_disambiguate kind ty f x =

733

try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) ->

734

raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names)))

735

736

module Label = NameChoice (struct

737

type t = label_description

738

type usage = unit

739

let type_kind = "record"

740

let get_name lbl = lbl.lbl_name

741

let get_type lbl = lbl.lbl_res

742

let lookup_all_from_type loc () path env =

743

Env.lookup_all_labels_from_type ~loc path env

744

let in_env lbl =

745

match lbl.lbl_repres with

746

| Record_regular | Record_float | Record_unboxed false -> true

747

| Record_unboxed true | Record_inlined _ | Record_extension _ -> false

748

end)

749

750

let disambiguate_label_by_ids keep closed ids labels =

751

let check_ids (lbl, _) =

752

let lbls = Hashtbl.create 8 in

753

Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;

754

List.for_all (Hashtbl.mem lbls) ids

755

and check_closed (lbl, _) =

756

(not closed || List.length ids = Array.length lbl.lbl_all)

757

in

758

let labels' = List.filter check_ids labels in

759

if keep && labels' = [] then (false, labels) else

760

let labels'' = List.filter check_closed labels' in

761

if keep && labels'' = [] then (false, labels') else (true, labels'')

762

763

(* Only issue warnings once per record constructor/pattern *)

764

let disambiguate_lid_a_list loc closed env opath lid_a_list =

765

let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in

766

let w_pr = ref false and w_amb = ref []

767

and w_scope = ref [] and w_scope_ty = ref "" in

768

let warn loc msg =

769

let open Warnings in

770

match msg with

771

| Not_principal _ -> w_pr := true

772

| Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb

773

| Name_out_of_scope(ty, [s], _) ->

774

w_scope := s :: !w_scope; w_scope_ty := ty

775

| _ -> Location.prerr_warning loc msg

776

in

777

let process_label lid =

778

(* Strategy for each field:

779

* collect all the labels in scope for that name

780

* if the type is known and principal, just eventually warn

781

if the real label was not in scope

782

* fail if there is no known type and no label found

783

* otherwise use other fields to reduce the list of candidates

784

* if there is no known type reduce it incrementally, so that

785

there is still at least one candidate (for error message)

786

* if the reduced list is valid, call Label.disambiguate

787

*)

788

let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in

789

match opath, scope with

790

| None, Error(loc, env, err) ->

791

Env.lookup_error loc env err

792

| Some _, Error _ ->

793

Label.disambiguate () lid env opath scope ~warn ~scope

794

| _, Ok lbls ->

795

let (ok, lbls) =

796

match opath with

797

| Some (_, _, true) ->

798

(true, lbls) (* disambiguate only checks scope *)

799

| _ -> disambiguate_label_by_ids (opath=None) closed ids lbls

800

in

801

if ok then Label.disambiguate () lid env opath (Ok lbls) ~warn ~scope

802

else fst (List.hd lbls) (* will fail later *)

803

in

804

let lbl_a_list =

805

List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in

806

if !w_pr then

807

Location.prerr_warning loc

808

(Warnings.Not_principal "this type-based record disambiguation")

809

else begin

810

match List.rev !w_amb with

811

(_,types,ex)::_ as amb ->

812

let paths =

813

List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in

814

let path = List.hd paths in

815

let fst3 (x,_,_) = x in

816

if List.for_all (compare_type_path env path) (List.tl paths) then

817

Location.prerr_warning loc

818

(Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))

819

else

820

List.iter

821

(fun (s,l,ex) -> Location.prerr_warning loc

822

(Warnings.Ambiguous_name ([s],l,false, ex)))

823

amb

824

| _ -> ()

825

end;

826

if !w_scope <> [] then

827

Location.prerr_warning loc

828

(Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));

829

lbl_a_list

830

831

let rec find_record_qual = function

832

| [] -> None

833

| ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname

834

| _ :: rest -> find_record_qual rest

835

836

let map_fold_cont f xs k =

837

List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))

838

xs (fun ys -> k (List.rev ys)) []

839

840

let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k =

841

let lbl_a_list =

842

match lid_a_list, labels with

843

({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->

844

(* Special case for rebuilt syntax trees *)

845

List.map

846

(function lid, a -> match lid.txt with

847

Longident.Lident s -> lid, Hashtbl.find labels s, a

848

| _ -> assert false)

849

lid_a_list

850

| _ ->

851

let lid_a_list =

852

match find_record_qual lid_a_list with

853

None -> lid_a_list

854

| Some modname ->

855

List.map

856

(fun (lid, a as lid_a) ->

857

match lid.txt with Longident.Lident s ->

858

{lid with txt=Longident.Ldot (modname, s)}, a

859

| _ -> lid_a)

860

lid_a_list

861

in

862

disambiguate_lid_a_list loc closed env opath lid_a_list

863

in

864

(* Invariant: records are sorted in the typed tree *)

865

let lbl_a_list =

866

List.sort

867

(fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)

868

lbl_a_list

869

in

870

map_fold_cont type_lbl_a lbl_a_list k

871

;;

872

873

(* Checks over the labels mentioned in a record pattern:

874

no duplicate definitions (error); properly closed (warning) *)

875

876

let check_recordpat_labels loc lbl_pat_list closed =

877

match lbl_pat_list with

878

| [] -> () (* should not happen *)

879

| (_, label1, _) :: _ ->

880

let all = label1.lbl_all in

881

let defined = Array.make (Array.length all) false in

882

let check_defined (_, label, _) =

883

if defined.(label.lbl_pos)

884

then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))

885

else defined.(label.lbl_pos) <- true in

886

List.iter check_defined lbl_pat_list;

887

if closed = Closed

888

&& Warnings.is_active (Warnings.Non_closed_record_pattern "")

889

then begin

890

let undefined = ref [] in

891

for i = 0 to Array.length all - 1 do

892

if not defined.(i) then undefined := all.(i).lbl_name :: !undefined

893

done;

894

if !undefined <> [] then begin

895

let u = String.concat ", " (List.rev !undefined) in

896

Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)

897

end

898

end

899

900

(* Constructors *)

901

902

module Constructor = NameChoice (struct

903

type t = constructor_description

904

type usage = Env.constructor_usage

905

let type_kind = "variant"

906

let get_name cstr = cstr.cstr_name

907

let get_type cstr = cstr.cstr_res

908

let lookup_all_from_type loc usage path env =

909

Env.lookup_all_constructors_from_type ~loc usage path env

910

let in_env _ = true

911

end)

912

913

(* unification of a type with a tconstr with

914

freshly created arguments *)

915

let unify_head_only ~refine loc env ty constr =

916

let (_, ty_res) = instance_constructor constr in

917

let ty_res = repr ty_res in

918

match ty_res.desc with

919

| Tconstr(p,args,m) ->

920

ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);

921

enforce_constraints !env ty_res;

922

unify_pat_types ~refine loc env ty_res ty

923

| _ -> assert false

924

925

(* Typing of patterns *)

926

927

(* "half typed" cases are produced in [type_cases] when we've just typechecked

928

the pattern but haven't type-checked the body yet.

929

At this point we might have added some type equalities to the environment,

930

but haven't yet added identifiers bound by the pattern. *)

931

type half_typed_case =

932

{ typed_pat: pattern;

933

pat_type_for_unif: type_expr;

934

untyped_case: Parsetree.case;

935

branch_env: Env.t;

936

pat_vars: pattern_variable list;

937

unpacks: module_variable list;

938

contains_gadt: bool; }

939

940

let rec has_literal_pattern p = match p.ppat_desc with

941

| Ppat_constant _

942

| Ppat_interval _ ->

943

true

944

| Ppat_any

945

| Ppat_variant (_, None)

946

| Ppat_construct (_, None)

947

| Ppat_type _

948

| Ppat_var _

949

| Ppat_unpack _

950

| Ppat_extension _ ->

951

false

952

| Ppat_exception p

953

| Ppat_variant (_, Some p)

954

| Ppat_construct (_, Some p)

955

| Ppat_constraint (p, _)

956

| Ppat_alias (p, _)

957

| Ppat_lazy p

958

| Ppat_open (_, p) ->

959

has_literal_pattern p

960

| Ppat_tuple ps

961

| Ppat_array ps ->

962

List.exists has_literal_pattern ps

963

| Ppat_record (ps, _) ->

964

List.exists (fun (_,p) -> has_literal_pattern p) ps

965

| Ppat_or (p, q) ->

966

has_literal_pattern p || has_literal_pattern q

967

968

let check_scope_escape loc env level ty =

969

try Ctype.check_scope_escape env level ty

970

with Unify trace ->

971

raise(Error(loc, env, Pattern_type_clash(trace, None)))

972

973

type pattern_checking_mode =

974

| Normal

975

(** We are checking user code. *)

976

| Counter_example of counter_example_checking_info

977

(** In [Counter_example] mode, we are checking a counter-example

978

candidate produced by Parmatch. This is a syntactic pattern that

979

represents a set of values by using or-patterns (p_1 | ... | p_n)

980

to enumerate all alternatives in the counter-example

981

search. These or-patterns occur at every choice point, possibly

982

deep inside the pattern.

983

984

Parmatch does not use type information, so this pattern may

985

exhibit two issues:

986

- some parts of the pattern may be ill-typed due to GADTs, and

987

- some wildcard patterns may not match any values: their type is

988

empty.

989

990

The aim of [type_pat] in the [Counter_example] mode is to refine

991

this syntactic pattern into a well-typed pattern, and ensure

992

that it matches at least one concrete value.

993

- It filters ill-typed branches of or-patterns.

994

(see {!splitting_mode} below)

995

- It tries to check that wildcard patterns are non-empty.

996

(see {!explosion_fuel})

997

*)

998

999

and counter_example_checking_info = {

1000

explosion_fuel: int;

1001

splitting_mode: splitting_mode;

1002

constrs: (string, Types.constructor_description) Hashtbl.t;

1003

labels: (string, Types.label_description) Hashtbl.t;

1004

}

1005

(**

1006

[explosion_fuel] controls the checking of wildcard patterns. We

1007

eliminate potentially-empty wildcard patterns by exploding them

1008

into concrete sub-patterns, for example (K1 _ | K2 _) or

1009

{ l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard

1010

explosion. Such depth limit is required to avoid non-termination

1011

and compilation-time blowups.

1012

1013

[splitting_mode] controls the handling of or-patterns. In

1014

[Counter_example] mode, we only need to select one branch that

1015

leads to a well-typed pattern. Checking all branches is expensive,

1016

we use different search strategies (see {!splitting_mode}) to

1017

reduce the number of explored alternatives.

1018

1019

[constrs] and [labels] contain metadata produced by [Parmatch] to

1020

type-check the given syntactic pattern. [Parmatch] produces

1021

counter-examples by turning typed patterns into

1022

[Parsetree.pattern]. In this process, constructor and label paths

1023

are lost, and are replaced by generated strings. [constrs] and

1024

[labels] map those synthetic names back to the typed descriptions

1025

of the original names.

1026

*)

1027

1028

(** Due to GADT constraints, an or-pattern produced within

1029

a counter-example may have ill-typed branches. Consider for example

1030

1031

type _ tag = Int : int tag | Bool : bool tag

1032

1033

then [Parmatch] will propose the or-pattern [Int | Bool] whenever

1034

a pattern of type [tag] is required to form a counter-example. For

1035

example, a function expects a (int tag option) and only [None] is

1036

handled by the user-written pattern. [Some (Int | Bool)] is not

1037

well-typed in this context, only the sub-pattern [Some Int] is.

1038

In this example, the expected type coming from the context

1039

suffices to know which or-pattern branch must be chosen.

1040

1041

In the general case, choosing a branch can have non-local effects

1042

on the typability of the term. For example, consider a tuple type

1043

['a tag * ...'a...], where the first component is a GADT. All

1044

constructor choices for this GADT lead to a well-typed branch in

1045

isolation (['a] is unconstrained), but choosing one of them adds

1046

a constraint on ['a] that may make the other tuple elements

1047

ill-typed.

1048

1049

In general, after choosing each possible branch of the or-pattern,

1050

[type_pat] has to check the rest of the pattern to tell if this

1051

choice leads to a well-typed term. This may lead to an explosion

1052

of typing/search work -- the rest of the term may in turn contain

1053

alternatives.

1054

1055

We use careful strategies to try to limit counterexample-checking

1056

time; [splitting_mode] represents those strategies.

1057

*)

1058

and splitting_mode =

1059

| Backtrack_or

1060

(** Always backtrack in or-patterns.

1061

1062

[Backtrack_or] selects a single alternative from an or-pattern

1063

by using backtracking, trying to choose each branch in turn, and

1064

to complete it into a valid sub-pattern. We call this

1065

"splitting" the or-pattern.

1066

1067

We use this mode when looking for unused patterns or sub-patterns,

1068

in particular to check a refutation clause (p -> .).

1069

*)

1070

| Refine_or of { inside_nonsplit_or: bool; }

1071

(** Only backtrack when needed.

1072

1073

[Refine_or] tries another approach for refining or-pattern.

1074

1075

Instead of always splitting each or-pattern, It first attempts to

1076

find branches that do not introduce new constraints (because they

1077

do not contain GADT constructors). Those branches are such that,

1078

if they fail, all other branches will fail.

1079

1080

If we find one such branch, we attempt to complete the subpattern

1081

(checking what's outside the or-pattern), ignoring other

1082

branches -- we never consider another branch choice again. If all

1083

branches are constrained, it falls back to splitting the

1084

or-pattern.

1085

1086

We use this mode when checking exhaustivity of pattern matching.

1087

*)

1088

1089

(** This exception is only used internally within [type_pat_aux], to jump

1090

back to the parent or-pattern in the [Refine_or] strategy.

1091

1092

Such a parent exists precisely when [inside_nonsplit_or = true];

1093

it's an invariant that we always setup an exception handler for

1094

[Need_backtrack] when we set this flag. *)

1095

exception Need_backtrack

1096

1097

(** Remember current typing state for backtracking.

1098

No variable information, as we only backtrack on

1099

patterns without variables (cf. assert statements). *)

1100

type state =

1101

{ snapshot: Btype.snapshot;

1102

levels: Ctype.levels;

1103

env: Env.t; }

1104

let save_state env =

1105

{ snapshot = Btype.snapshot ();

1106

levels = Ctype.save_levels ();

1107

env = !env; }

1108

let set_state s env =

1109

Btype.backtrack s.snapshot;

1110

Ctype.set_levels s.levels;

1111

env := s.env

1112

1113

(** Find the first alternative in the tree of or-patterns for which

1114

[f] does not raise an error. If all fail, the last error is

1115

propagated *)

1116

let rec find_valid_alternative f pat =

1117

match pat.ppat_desc with

1118

| Ppat_or(p1,p2) ->

1119

(try find_valid_alternative f p1

1120

with Error _ -> find_valid_alternative f p2)

1121

| _ -> f pat

1122

1123

let no_explosion = function

1124

| Normal -> Normal

1125

| Counter_example info ->

1126

Counter_example { info with explosion_fuel = 0 }

1127

1128

let get_splitting_mode = function

1129

| Normal -> None

1130

| Counter_example {splitting_mode} -> Some splitting_mode

1131

1132

let enter_nonsplit_or mode = match mode with

1133

| Normal -> Normal

1134

| Counter_example info ->

1135

let splitting_mode = match info.splitting_mode with

1136

| Backtrack_or ->

1137

(* in Backtrack_or mode, or-patterns are always split *)

1138

assert false

1139

| Refine_or _ ->

1140

Refine_or {inside_nonsplit_or = true}

1141

in Counter_example { info with splitting_mode }

1142

1143

let rec type_pat ?(exception_allowed=false) ~no_existentials ~mode

1144

~env sp expected_ty k =

1145

Builtin_attributes.warning_scope sp.ppat_attributes

1146

(fun () ->

1147

type_pat_aux ~exception_allowed ~no_existentials ~mode

1148

~env sp expected_ty k

1149

)

1150

1151

and type_pat_aux ~exception_allowed ~no_existentials ~mode

1152

~env sp expected_ty k =

1153

let type_pat ?(exception_allowed=false) ?(mode=mode) ?(env=env) =

1154

type_pat ~exception_allowed ~no_existentials ~mode ~env

1155

in

1156

let loc = sp.ppat_loc in

1157

let refine = match mode with Normal -> false | Counter_example _ -> true in

1158

let rup k x =

1159

if mode = Normal then (ignore (rp x));

1160

unify_pat ~refine env x (instance expected_ty);

1161

k x

1162

in

1163

let rp k x : pattern = if mode = Normal then k (rp x) else k x in

1164

let construction_not_used_in_counterexamples = (mode = Normal) in

1165

let must_backtrack_on_gadt = match get_splitting_mode mode with

1166

| None -> false

1167

| Some Backtrack_or -> false

1168

| Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or

1169

in

1170

match sp.ppat_desc with

1171

Ppat_any ->

1172

let k' d = rp k {

1173

pat_desc = d;

1174

pat_loc = loc; pat_extra=[];

1175

pat_type = instance expected_ty;

1176

pat_attributes = sp.ppat_attributes;

1177

pat_env = !env }

1178

in

1179

begin match mode with

1180

| Normal -> k' Tpat_any

1181

| Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->

1182

k' Tpat_any

1183

| Counter_example ({explosion_fuel; _} as info) ->

1184

begin match Parmatch.ppat_of_type !env expected_ty with

1185

| exception Parmatch.Empty -> raise (Error (loc, !env, Empty_pattern))

1186

| (sp, constrs, labels) ->

1187

if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else

1188

if must_backtrack_on_gadt then raise Need_backtrack else

1189

let explosion_fuel =

1190

match sp.ppat_desc with

1191

Parsetree.Ppat_or _ -> explosion_fuel - 5

1192

| _ -> explosion_fuel - 1

1193

in

1194

let mode =

1195

Counter_example { info with explosion_fuel; constrs; labels }

1196

in

1197

type_pat ~mode sp expected_ty k

1198

end

1199

end

1200

| Ppat_var name ->

1201

let ty = instance expected_ty in

1202

let id = (* PR#7330 *)

1203

if name.txt = "*extension*" then

1204

Ident.create_local name.txt

1205

else

1206

enter_variable loc name ty sp.ppat_attributes

1207

in

1208

rp k {

1209

pat_desc = Tpat_var (id, name);

1210

pat_loc = loc; pat_extra=[];

1211

pat_type = ty;

1212

pat_attributes = sp.ppat_attributes;

1213

pat_env = !env }

1214

| Ppat_unpack name ->

1215

assert construction_not_used_in_counterexamples;

1216

let t = instance expected_ty in

1217

begin match name.txt with

1218

| None ->

1219

rp k {

1220

pat_desc = Tpat_any;

1221

pat_loc = sp.ppat_loc;

1222

pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];

1223

pat_type = t;

1224

pat_attributes = [];

1225

pat_env = !env }

1226

| Some s ->

1227

let v = { name with txt = s } in

1228

let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in

1229

rp k {

1230

pat_desc = Tpat_var (id, v);

1231

pat_loc = sp.ppat_loc;

1232

pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];

1233

pat_type = t;

1234

pat_attributes = [];

1235

pat_env = !env }

1236

end

1237

| Ppat_constraint(

1238

{ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},

1239

({ptyp_desc=Ptyp_poly _} as sty)) ->

1240

(* explicitly polymorphic type *)

1241

assert construction_not_used_in_counterexamples;

1242

let cty, force = Typetexp.transl_simple_type_delayed !env sty in

1243

let ty = cty.ctyp_type in

1244

unify_pat_types ~refine lloc env ty (instance expected_ty);

1245

pattern_force := force :: !pattern_force;

1246

begin match ty.desc with

1247

| Tpoly (body, tyl) ->

1248

begin_def ();

1249

let _, ty' = instance_poly ~keep_names:true false tyl body in

1250

end_def ();

1251

generalize ty';

1252

let id = enter_variable lloc name ty' attrs in

1253

rp k {

1254

pat_desc = Tpat_var (id, name);

1255

pat_loc = lloc;

1256

pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];

1257

pat_type = ty;

1258

pat_attributes = [];

1259

pat_env = !env

1260

}

1261

| _ -> assert false

1262

end

1263

| Ppat_alias(sq, name) ->

1264

assert construction_not_used_in_counterexamples;

1265

type_pat sq expected_ty (fun q ->

1266

begin_def ();

1267

let ty_var = build_as_type env q in

1268

end_def ();

1269

generalize ty_var;

1270

let id =

1271

enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes

1272

in

1273

rp k {

1274

pat_desc = Tpat_alias(q, id, name);

1275

pat_loc = loc; pat_extra=[];

1276

pat_type = q.pat_type;

1277

pat_attributes = sp.ppat_attributes;

1278

pat_env = !env })

1279

| Ppat_constant cst ->

1280

let cst = constant_or_raise !env loc cst in

1281

rup k {

1282

pat_desc = Tpat_constant cst;

1283

pat_loc = loc; pat_extra=[];

1284

pat_type = type_constant cst;

1285

pat_attributes = sp.ppat_attributes;

1286

pat_env = !env }

1287

| Ppat_interval (Pconst_char c1, Pconst_char c2) ->

1288

let open Ast_helper.Pat in

1289

let gloc = {loc with Location.loc_ghost=true} in

1290

let rec loop c1 c2 =

1291

if c1 = c2 then constant ~loc:gloc (Pconst_char c1)

1292

else

1293

or_ ~loc:gloc

1294

(constant ~loc:gloc (Pconst_char c1))

1295

(loop (Char.chr(Char.code c1 + 1)) c2)

1296

in

1297

let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in

1298

let p = {p with ppat_loc=loc} in

1299

type_pat ~mode:(no_explosion mode) p expected_ty k

1300

(* TODO: record 'extra' to remember about interval *)

1301

| Ppat_interval _ ->

1302

raise (Error (loc, !env, Invalid_interval))

1303

| Ppat_tuple spl ->

1304

assert (List.length spl >= 2);

1305

let spl_ann = List.map (fun p -> (p,newgenvar ())) spl in

1306

let ty = newgenty (Ttuple(List.map snd spl_ann)) in

1307

begin_def ();

1308

let expected_ty = instance expected_ty in

1309

end_def ();

1310

generalize_structure expected_ty;

1311

unify_pat_types ~refine loc env ty expected_ty;

1312

map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl ->

1313

rp k {

1314

pat_desc = Tpat_tuple pl;

1315

pat_loc = loc; pat_extra=[];

1316

pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));

1317

pat_attributes = sp.ppat_attributes;

1318

pat_env = !env })

1319

| Ppat_construct(lid, sarg) ->

1320

let opath =

1321

try

1322

let (p0, p, _) = extract_concrete_variant !env expected_ty in

1323

Some (p0, p, true)

1324

with Not_found -> None

1325

in

1326

let constr =

1327

match lid.txt, mode with

1328

| Longident.Lident s, Counter_example {constrs; _} ->

1329

(* assert: cf. {!counter_example_checking_info} documentation *)

1330

assert (Hashtbl.mem constrs s);

1331

Hashtbl.find constrs s

1332

| _ ->

1333

let candidates =

1334

Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in

1335

wrap_disambiguate "This variant pattern is expected to have"

1336

(mk_expected expected_ty)

1337

(Constructor.disambiguate Env.Pattern lid !env opath) candidates

1338

in

1339

if constr.cstr_generalized && must_backtrack_on_gadt then

1340

raise Need_backtrack;

1341

begin match no_existentials, constr.cstr_existentials with

1342

| None, _ | _, [] -> ()

1343

| Some r, (_ :: _ as exs) ->

1344

let exs = List.map (Ctype.existential_name constr) exs in

1345

let name = constr.cstr_name in

1346

raise (Error (loc, !env, Unexpected_existential (r,name, exs)))

1347

end;

1348

(* if constructor is gadt, we must verify that the expected type has the

1349

correct head *)

1350

if constr.cstr_generalized then

1351

unify_head_only ~refine loc env (instance expected_ty) constr;

1352

let sargs =

1353

match sarg with

1354

None -> []

1355

| Some {ppat_desc = Ppat_tuple spl} when

1356

constr.cstr_arity > 1 ||

1357

Builtin_attributes.explicit_arity sp.ppat_attributes

1358

-> spl

1359

| Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->

1360

if constr.cstr_arity = 0 then

1361

Location.prerr_warning sp.ppat_loc

1362

Warnings.Wildcard_arg_to_constant_constr;

1363

replicate_list sp constr.cstr_arity

1364

| Some sp -> [sp] in

1365

if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then

1366

begin match List.filter has_literal_pattern sargs with

1367

| sp :: _ ->

1368

Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern

1369

| _ -> ()

1370

end;

1371

if List.length sargs <> constr.cstr_arity then

1372

raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,

1373

constr.cstr_arity, List.length sargs)));

1374

begin_def ();

1375

let (ty_args, ty_res) =

1376

instance_constructor ~in_pattern:(env, get_gadt_equations_level ())

1377

constr

1378

in

1379

let expected_ty = instance expected_ty in

1380

(* PR#7214: do not use gadt unification for toplevel lets *)

1381

unify_pat_types loc env ty_res expected_ty

1382

~refine:(refine || constr.cstr_generalized && no_existentials = None);

1383

end_def ();

1384

generalize_structure expected_ty;

1385

generalize_structure ty_res;

1386

List.iter generalize_structure ty_args;

1387

1388

let rec check_non_escaping p =

1389

match p.ppat_desc with

1390

| Ppat_or (p1, p2) ->

1391

check_non_escaping p1;

1392

check_non_escaping p2

1393

| Ppat_alias (p, _) ->

1394

check_non_escaping p

1395

| Ppat_constraint _ ->

1396

raise (Error (p.ppat_loc, !env, Inlined_record_escape))

1397

| _ ->

1398

()

1399

in

1400

if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;

1401

1402

map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args)

1403

(fun args ->

1404

rp k {

1405

pat_desc=Tpat_construct(lid, constr, args);

1406

pat_loc = loc; pat_extra=[];

1407

pat_type = instance expected_ty;

1408

pat_attributes = sp.ppat_attributes;

1409

pat_env = !env })

1410

| Ppat_variant(l, sarg) ->

1411

let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in

1412

let row = { row_fields =

1413

[l, Reither(sarg = None, arg_type, true, ref None)];

1414

row_bound = ();

1415

row_closed = false;

1416

row_more = newgenvar ();

1417

row_fixed = None;

1418

row_name = None } in

1419

begin_def ();

1420

let expected_ty = instance expected_ty in

1421

end_def ();

1422

generalize_structure expected_ty;

1423

(* PR#7404: allow some_private_tag blindly, as it would not unify with

1424

the abstract row variable *)

1425

if l = Parmatch.some_private_tag

1426

then assert (match mode with Normal -> false | Counter_example _ -> true)

1427

else unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;

1428

let k arg =

1429

rp k {

1430

pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});

1431

pat_loc = loc; pat_extra=[];

1432

pat_type = instance expected_ty;

1433

pat_attributes = sp.ppat_attributes;

1434

pat_env = !env }

1435

in begin

1436

(* PR#6235: propagate type information *)

1437

match sarg, arg_type with

1438

Some p, [ty] -> type_pat p ty (fun p -> k (Some p))

1439

| _ -> k None

1440

end

1441

| Ppat_record(lid_sp_list, closed) ->

1442

assert (lid_sp_list <> []);

1443

let opath, record_ty =

1444

try

1445

let (p0, p,_) = extract_concrete_record !env expected_ty in

1446

begin_def ();

1447

let ty = instance expected_ty in

1448

end_def ();

1449

generalize_structure ty;

1450

Some (p0, p, true), ty

1451

with Not_found -> None, newvar ()

1452

in

1453

let type_label_pat (label_lid, label, sarg) k =

1454

begin_def ();

1455

let (_, ty_arg, ty_res) = instance_label false label in

1456

begin try

1457

unify_pat_types ~refine loc env ty_res (instance record_ty)

1458

with Error(_loc, _env, Pattern_type_clash(trace, _)) ->

1459

raise(Error(label_lid.loc, !env,

1460

Label_mismatch(label_lid.txt, trace)))

1461

end;

1462

end_def ();

1463

generalize_structure ty_res;

1464

generalize_structure ty_arg;

1465

type_pat sarg ty_arg (fun arg ->

1466

k (label_lid, label, arg))

1467

in

1468

let k' k lbl_pat_list =

1469

check_recordpat_labels loc lbl_pat_list closed;

1470

rup k {

1471

pat_desc = Tpat_record (lbl_pat_list, closed);

1472

pat_loc = loc; pat_extra=[];

1473

pat_type = instance record_ty;

1474

pat_attributes = sp.ppat_attributes;

1475

pat_env = !env }

1476

in

1477

begin match mode with

1478

| Normal ->

1479

k (wrap_disambiguate "This record pattern is expected to have"

1480

(mk_expected expected_ty)

1481

(type_label_a_list loc false !env type_label_pat opath

1482

lid_sp_list)

1483

(k' (fun x -> x)))

1484

| Counter_example {labels; _} ->

1485

type_label_a_list ~labels loc false !env type_label_pat opath

1486

lid_sp_list (k' k)

1487

end

1488

| Ppat_array spl ->

1489

let ty_elt = newgenvar() in

1490

begin_def ();

1491

let expected_ty = instance expected_ty in

1492

end_def ();

1493

generalize_structure expected_ty;

1494

unify_pat_types ~refine

1495

loc env (Predef.type_array ty_elt) expected_ty;

1496

map_fold_cont (fun p -> type_pat p ty_elt) spl (fun pl ->

1497

rp k {

1498

pat_desc = Tpat_array pl;

1499

pat_loc = loc; pat_extra=[];

1500

pat_type = instance expected_ty;

1501

pat_attributes = sp.ppat_attributes;

1502

pat_env = !env })

1503

| Ppat_or(sp1, sp2) ->

1504

let may_split, must_split =

1505

match get_splitting_mode mode with

1506

| None -> false, false

1507

| Some Backtrack_or -> true, true

1508

| Some (Refine_or _) -> true, false in

1509

let state = save_state env in

1510

let split_or sp =

1511

assert may_split;

1512

let typ pat = type_pat ~exception_allowed pat expected_ty k in

1513

find_valid_alternative (fun pat -> set_state state env; typ pat) sp in

1514

if must_split then split_or sp else begin

1515

let initial_pattern_variables = !pattern_variables in

1516

let initial_module_variables = !module_variables in

1517

let equation_level = !gadt_equations_level in

1518

let outter_lev = get_current_level () in

1519

(* introduce a new scope *)

1520

begin_def ();

1521

let lev = get_current_level () in

1522

gadt_equations_level := Some lev;

1523

let env1 = ref !env in

1524

let inside_or = enter_nonsplit_or mode in

1525

let p1 =

1526

try Some (type_pat ~exception_allowed ~mode:inside_or

1527

sp1 expected_ty ~env:env1 (fun x -> x))

1528

with Need_backtrack -> None in

1529

let p1_variables = !pattern_variables in

1530

let p1_module_variables = !module_variables in

1531

pattern_variables := initial_pattern_variables;

1532

module_variables := initial_module_variables;

1533

let env2 = ref !env in

1534

let p2 =

1535

try Some (type_pat ~exception_allowed ~mode:inside_or

1536

sp2 expected_ty ~env:env2 (fun x -> x))

1537

with Need_backtrack -> None in

1538

end_def ();

1539

gadt_equations_level := equation_level;

1540

let p2_variables = !pattern_variables in

1541

(* Make sure no variable with an ambiguous type gets added to the

1542

environment. *)

1543

List.iter (fun { pv_type; pv_loc; _ } ->

1544

check_scope_escape pv_loc !env1 outter_lev pv_type

1545

) p1_variables;

1546

List.iter (fun { pv_type; pv_loc; _ } ->

1547

check_scope_escape pv_loc !env2 outter_lev pv_type

1548

) p2_variables;

1549

begin match p1, p2 with

1550

| None, None ->

1551

let inside_nonsplit_or =

1552

match get_splitting_mode mode with

1553

| None | Some Backtrack_or -> false

1554

| Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or in

1555

if inside_nonsplit_or

1556

then raise Need_backtrack

1557

else split_or sp

1558

| Some p, None | None, Some p -> rp k p (* no variables in this case *)

1559

| Some p1, Some p2 ->

1560

let alpha_env =

1561

enter_orpat_variables loc !env p1_variables p2_variables in

1562

pattern_variables := p1_variables;

1563

module_variables := p1_module_variables;

1564

rp k { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);

1565

pat_loc = loc;

1566

pat_extra=[];

1567

pat_type = instance expected_ty;

1568

pat_attributes = sp.ppat_attributes;

1569

pat_env = !env }

1570

end

1571

end

1572

| Ppat_lazy sp1 ->

1573

let nv = newgenvar () in

1574

unify_pat_types ~refine loc env (Predef.type_lazy_t nv) expected_ty;

1575

(* do not explode under lazy: PR#7421 *)

1576

type_pat ~mode:(no_explosion mode) sp1 nv (fun p1 ->

1577

rp k {

1578

pat_desc = Tpat_lazy p1;

1579

pat_loc = loc; pat_extra=[];

1580

pat_type = instance expected_ty;

1581

pat_attributes = sp.ppat_attributes;

1582

pat_env = !env })

1583

| Ppat_constraint(sp, sty) ->

1584

(* Pretend separate = true *)

1585

begin_def();

1586

let cty, force = Typetexp.transl_simple_type_delayed !env sty in

1587

let ty = cty.ctyp_type in

1588

end_def();

1589

generalize_structure ty;

1590

let ty, expected_ty' = instance ty, ty in

1591

unify_pat_types ~refine loc env ty (instance expected_ty);

1592

type_pat ~exception_allowed sp expected_ty' (fun p ->

1593

(*Format.printf "%a@.%a@."

1594

Printtyp.raw_type_expr ty

1595

Printtyp.raw_type_expr p.pat_type;*)

1596

pattern_force := force :: !pattern_force;

1597

let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in

1598

let p =

1599

match p.pat_desc with

1600

Tpat_var (id,s) ->

1601

{p with pat_type = ty;

1602

pat_desc = Tpat_alias

1603

({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);

1604

pat_extra = [extra];

1605

}

1606

| _ -> {p with pat_type = ty;

1607

pat_extra = extra :: p.pat_extra}

1608

in k p)

1609

| Ppat_type lid ->

1610

let (path, p,ty) = build_or_pat !env loc lid in

1611

unify_pat_types ~refine loc env ty (instance expected_ty);

1612

k { p with pat_extra =

1613

(Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }

1614

| Ppat_open (lid,p) ->

1615

let path, new_env =

1616

!type_open Asttypes.Fresh !env sp.ppat_loc lid in

1617

let new_env = ref new_env in

1618

type_pat ~exception_allowed ~env:new_env p expected_ty ( fun p ->

1619

env := Env.copy_local !env ~from:!new_env;

1620

k { p with pat_extra =( Tpat_open (path,lid,!new_env),

1621

loc, sp.ppat_attributes) :: p.pat_extra }

1622

)

1623

| Ppat_exception p ->

1624

if not exception_allowed then

1625

raise (Error (loc, !env, Exception_pattern_disallowed))

1626

else begin

1627

type_pat p Predef.type_exn (fun p_exn ->

1628

rp k {

1629

pat_desc = Tpat_exception p_exn;

1630

pat_loc = sp.ppat_loc;

1631

pat_extra = [];

1632

pat_type = expected_ty;

1633

pat_env = !env;

1634

pat_attributes = sp.ppat_attributes;

1635

})

1636

end

1637

| Ppat_extension ext ->

1638

raise (Error_forward (Builtin_attributes.error_of_extension ext))

1639

1640

let type_pat ?exception_allowed ?no_existentials ?(mode=Normal)

1641

?(lev=get_current_level()) env sp expected_ty =

1642

Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->

1643

let r =

1644

type_pat ?exception_allowed ~no_existentials ~mode

1645

~env sp expected_ty (fun x -> x)

1646

in

1647

iter_pattern (fun p -> p.pat_env <- !env) r;

1648

r

1649

)

1650

1651

(* this function is passed to Partial.parmatch

1652

to type check gadt nonexhaustiveness *)

1653

let partial_pred ~lev ~splitting_mode ?(explode=0)

1654

env expected_ty constrs labels p =

1655

let env = ref env in

1656

let state = save_state env in

1657

let mode =

1658

Counter_example {

1659

splitting_mode;

1660

explosion_fuel = explode;

1661

constrs; labels;

1662

} in

1663

try

1664

reset_pattern None true;

1665

let typed_p =

1666

Ctype.with_passive_variants (type_pat ~lev ~mode env p) expected_ty

1667

in

1668

set_state state env;

1669

(* types are invalidated but we don't need them here *)

1670

Some typed_p

1671

with Error _ ->

1672

set_state state env;

1673

None

1674

1675

let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =

1676

let explode = match cases with [_] -> 5 | _ -> 0 in

1677

let splitting_mode = Refine_or {inside_nonsplit_or = false} in

1678

Parmatch.check_partial

1679

(partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases

1680

1681

let check_unused ?(lev=get_current_level ()) env expected_ty cases =

1682

Parmatch.check_unused

1683

(fun refute constrs labels spat ->

1684

match

1685

partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5

1686

env expected_ty constrs labels spat

1687

with

1688

Some pat when refute ->

1689

raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))

1690

| r -> r)

1691

cases

1692

1693

let iter_pattern_variables_type f : pattern_variable list -> unit =

1694

List.iter (fun {pv_type; _} -> f pv_type)

1695

1696

let add_pattern_variables ?check ?check_as env pv =

1697

List.fold_right

1698

(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->

1699

let check = if pv_as_var then check_as else check in

1700

Env.add_value ?check pv_id

1701

{val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;

1702

val_attributes = pv_attributes;

1703

} env

1704

)

1705

pv env

1706

1707

let type_pattern ?exception_allowed ~lev env spat scope expected_ty =

1708

reset_pattern scope true;

1709

let new_env = ref env in

1710

let pat = type_pat ?exception_allowed ~lev new_env spat expected_ty in

1711

let pvs = get_ref pattern_variables in

1712

let unpacks = get_ref module_variables in

1713

(pat, !new_env, get_ref pattern_force, pvs, unpacks)

1714

1715

let type_pattern_list no_existentials env spatl scope expected_tys allow =

1716

reset_pattern scope allow;

1717

let new_env = ref env in

1718

let type_pat (attrs, pat) ty =

1719

Builtin_attributes.warning_scope ~ppwarning:false attrs

1720

(fun () ->

1721

type_pat ~no_existentials new_env pat ty

1722

)

1723

in

1724

let patl = List.map2 type_pat spatl expected_tys in

1725

let pvs = get_ref pattern_variables in

1726

let unpacks = get_ref module_variables in

1727

let new_env = add_pattern_variables !new_env pvs in

1728

(patl, new_env, get_ref pattern_force, pvs, unpacks)

1729

1730

let type_class_arg_pattern cl_num val_env met_env l spat =

1731

reset_pattern None false;

1732

let nv = newvar () in

1733

let pat = type_pat ~no_existentials:In_class_args (ref val_env) spat nv in

1734

if has_variants pat then begin

1735

Parmatch.pressure_variants val_env [pat];

1736

iter_pattern finalize_variant pat

1737

end;

1738

List.iter (fun f -> f()) (get_ref pattern_force);

1739

if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));

1740

let (pv, met_env) =

1741

List.fold_right

1742

(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} (pv, env) ->

1743

let check s =

1744

if pv_as_var then Warnings.Unused_var s

1745

else Warnings.Unused_var_strict s in

1746

let id' = Ident.create_local (Ident.name pv_id) in

1747

((id', pv_id, pv_type)::pv,

1748

Env.add_value id' {val_type = pv_type;

1749

val_kind = Val_ivar (Immutable, cl_num);

1750

val_attributes = pv_attributes;

1751

Types.val_loc = pv_loc;

1752

} ~check

1753

env))

1754

!pattern_variables ([], met_env)

1755

in

1756

let val_env = add_pattern_variables val_env (get_ref pattern_variables) in

1757

(pat, pv, val_env, met_env)

1758

1759

let type_self_pattern cl_num privty val_env met_env par_env spat =

1760

let open Ast_helper in

1761

let spat =

1762

Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),

1763

mknoloc ("selfpat-" ^ cl_num)))

1764

in

1765

reset_pattern None false;

1766

let nv = newvar() in

1767

let pat = type_pat ~no_existentials:In_self_pattern (ref val_env) spat nv in

1768

List.iter (fun f -> f()) (get_ref pattern_force);

1769

let meths = ref Meths.empty in

1770

let vars = ref Vars.empty in

1771

let pv = !pattern_variables in

1772

pattern_variables := [];

1773

let (val_env, met_env, par_env) =

1774

List.fold_right

1775

(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}

1776

(val_env, met_env, par_env) ->

1777

let name = Ident.name pv_id in

1778

(Env.enter_unbound_value name Val_unbound_self val_env,

1779

Env.add_value pv_id {val_type = pv_type;

1780

val_kind =

1781

Val_self (meths, vars, cl_num, privty);

1782

val_attributes = pv_attributes;

1783

Types.val_loc = pv_loc;

1784

}

1785

~check:(fun s -> if pv_as_var then Warnings.Unused_var s

1786

else Warnings.Unused_var_strict s)

1787

met_env,

1788

Env.enter_unbound_value name Val_unbound_self par_env))

1789

pv (val_env, met_env, par_env)

1790

in

1791

(pat, meths, vars, val_env, met_env, par_env)

1792

1793

let delayed_checks = ref []

1794

let reset_delayed_checks () = delayed_checks := []

1795

let add_delayed_check f =

1796

delayed_checks := (f, Warnings.backup ()) :: !delayed_checks

1797

1798

let force_delayed_checks () =

1799

(* checks may change type levels *)

1800

let snap = Btype.snapshot () in

1801

let w_old = Warnings.backup () in

1802

List.iter

1803

(fun (f, w) -> Warnings.restore w; f ())

1804

(List.rev !delayed_checks);

1805

Warnings.restore w_old;

1806

reset_delayed_checks ();

1807

Btype.backtrack snap

1808

1809

let rec final_subexpression exp =

1810

match exp.exp_desc with

1811

Texp_let (_, _, e)

1812

| Texp_sequence (_, e)

1813

| Texp_try (e, _)

1814

| Texp_ifthenelse (_, e, _)

1815

| Texp_match (_, {c_rhs=e} :: _, _)

1816

| Texp_letmodule (_, _, _, _, e)

1817

| Texp_letexception (_, e)

1818

| Texp_open (_, e)

1819

-> final_subexpression e

1820

| _ -> exp

1821

1822

(* Generalization criterion for expressions *)

1823

1824

let rec is_nonexpansive exp =

1825

match exp.exp_desc with

1826

| Texp_ident _

1827

| Texp_constant _

1828

| Texp_unreachable

1829

| Texp_function _

1830

| Texp_array [] -> true

1831

| Texp_let(_rec_flag, pat_exp_list, body) ->

1832

List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&

1833

is_nonexpansive body

1834

| Texp_apply(e, (_,None)::el) ->

1835

is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)

1836

| Texp_match(e, cases, _) ->

1837

(* Not sure this is necessary, if [e] is nonexpansive then we shouldn't

1838

care if there are exception patterns. But the previous version enforced

1839

that there be none, so... *)

1840

let contains_exception_pat p =

1841

let res = ref false in

1842

iter_pattern (fun p ->

1843

match p.pat_desc with

1844

| Tpat_exception _ -> res := true

1845

| _ -> ()

1846

) p;

1847

!res

1848

in

1849

is_nonexpansive e &&

1850

List.for_all

1851

(fun {c_lhs; c_guard; c_rhs} ->

1852

is_nonexpansive_opt c_guard && is_nonexpansive c_rhs

1853

&& not (contains_exception_pat c_lhs)

1854

) cases

1855

| Texp_tuple el ->

1856

List.for_all is_nonexpansive el

1857

| Texp_construct( _, _, el) ->

1858

List.for_all is_nonexpansive el

1859

| Texp_variant(_, arg) -> is_nonexpansive_opt arg

1860

| Texp_record { fields; extended_expression } ->

1861

Array.for_all

1862

(fun (lbl, definition) ->

1863

match definition with

1864

| Overridden (_, exp) ->

1865

lbl.lbl_mut = Immutable && is_nonexpansive exp

1866

| Kept _ -> true)

1867

fields

1868

&& is_nonexpansive_opt extended_expression

1869

| Texp_field(exp, _, _) -> is_nonexpansive exp

1870

| Texp_ifthenelse(_cond, ifso, ifnot) ->

1871

is_nonexpansive ifso && is_nonexpansive_opt ifnot

1872

| Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *)

1873

| Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0

1874

(* Note: nonexpansive only means no _observable_ side effects *)

1875

| Texp_lazy e -> is_nonexpansive e

1876

| Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->

1877

let count = ref 0 in

1878

List.for_all

1879

(fun field -> match field.cf_desc with

1880

Tcf_method _ -> true

1881

| Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->

1882

incr count; is_nonexpansive e

1883

| Tcf_val (_, _, _, Tcfk_virtual _, _) ->

1884

incr count; true

1885

| Tcf_initializer e -> is_nonexpansive e

1886

| Tcf_constraint _ -> true

1887

| Tcf_inherit _ -> false

1888

| Tcf_attribute _ -> true)

1889

fields &&

1890

Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)

1891

vars true &&

1892

!count = 0

1893

| Texp_letmodule (_, _, _, mexp, e)

1894

| Texp_open ({ open_expr = mexp; _}, e) ->

1895

is_nonexpansive_mod mexp && is_nonexpansive e

1896

| Texp_pack mexp ->

1897

is_nonexpansive_mod mexp

1898

(* Computations which raise exceptions are nonexpansive, since (raise e) is

1899

equivalent to (raise e; diverge), and a nonexpansive "diverge" can be

1900

produced using lazy values or the relaxed value restriction.

1901

See GPR#1142 *)

1902

| Texp_assert exp ->

1903

is_nonexpansive exp

1904

| Texp_apply (

1905

{ exp_desc = Texp_ident (_, _, {val_kind =

1906

Val_prim {Primitive.prim_name =

1907

("%raise" | "%reraise" | "%raise_notrace")}}) },

1908

[Nolabel, Some e]) ->

1909

is_nonexpansive e

1910

| Texp_array (_ :: _)

1911

| Texp_apply _

1912

| Texp_try _

1913

| Texp_setfield _

1914

| Texp_while _

1915

| Texp_for _

1916

| Texp_send _

1917

| Texp_instvar _

1918

| Texp_setinstvar _

1919

| Texp_override _

1920

| Texp_letexception _

1921

| Texp_letop _

1922

| Texp_extension_constructor _ ->

1923

false

1924

1925

and is_nonexpansive_mod mexp =

1926

match mexp.mod_desc with

1927

| Tmod_ident _

1928

| Tmod_functor _ -> true

1929

| Tmod_unpack (e, _) -> is_nonexpansive e

1930

| Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m

1931

| Tmod_structure str ->

1932

List.for_all

1933

(fun item -> match item.str_desc with

1934

| Tstr_eval _ | Tstr_primitive _ | Tstr_type _

1935

| Tstr_modtype _ | Tstr_class_type _ -> true

1936

| Tstr_value (_, pat_exp_list) ->

1937

List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list

1938

| Tstr_module {mb_expr=m;_}

1939

| Tstr_open {open_expr=m;_}

1940

| Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m

1941

| Tstr_recmodule id_mod_list ->

1942

List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)

1943

id_mod_list

1944

| Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->

1945

false (* true would be unsound *)

1946

| Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->

1947

true

1948

| Tstr_typext te ->

1949

List.for_all

1950

(function {ext_kind = Text_decl _} -> false

1951

| {ext_kind = Text_rebind _} -> true)

1952

te.tyext_constructors

1953

| Tstr_class _ -> false (* could be more precise *)

1954

| Tstr_attribute _ -> true

1955

)

1956

str.str_items

1957

| Tmod_apply _ -> false

1958

1959

and is_nonexpansive_opt = function

1960

| None -> true

1961

| Some e -> is_nonexpansive e

1962

1963

let maybe_expansive e = not (is_nonexpansive e)

1964

1965

let check_recursive_bindings env valbinds =

1966

let ids = let_bound_idents valbinds in

1967

List.iter

1968

(fun {vb_expr} ->

1969

if not (Rec_check.is_valid_recursive_expression ids vb_expr) then

1970

raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr))

1971

)

1972

valbinds

1973

1974

let check_recursive_class_bindings env ids exprs =

1975

List.iter

1976

(fun expr ->

1977

if not (Rec_check.is_valid_class_expr ids expr) then

1978

raise(Error(expr.cl_loc, env, Illegal_class_expr)))

1979

exprs

1980

1981

(* Approximate the type of an expression, for better recursion *)

1982

1983

let rec approx_type env sty =

1984

match sty.ptyp_desc with

1985

Ptyp_arrow (p, _, sty) ->

1986

let ty1 = if is_optional p then type_option (newvar ()) else newvar () in

1987

newty (Tarrow (p, ty1, approx_type env sty, Cok))

1988

| Ptyp_tuple args ->

1989

newty (Ttuple (List.map (approx_type env) args))

1990

| Ptyp_constr (lid, ctl) ->

1991

let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in

1992

if List.length ctl <> decl.type_arity then newvar ()

1993

else begin

1994

let tyl = List.map (approx_type env) ctl in

1995

newconstr path tyl

1996

end

1997

| Ptyp_poly (_, sty) ->

1998

approx_type env sty

1999

| _ -> newvar ()

2000

2001

let rec type_approx env sexp =

2002

match sexp.pexp_desc with

2003

Pexp_let (_, _, e) -> type_approx env e

2004

| Pexp_fun (p, _, _, e) ->

2005

let ty = if is_optional p then type_option (newvar ()) else newvar () in

2006

newty (Tarrow(p, ty, type_approx env e, Cok))

2007

| Pexp_function ({pc_rhs=e}::_) ->

2008

newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))

2009

| Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e

2010

| Pexp_try (e, _) -> type_approx env e

2011

| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))

2012

| Pexp_ifthenelse (_,e,_) -> type_approx env e

2013

| Pexp_sequence (_,e) -> type_approx env e

2014

| Pexp_constraint (e, sty) ->

2015

let ty = type_approx env e in

2016

let ty1 = approx_type env sty in

2017

begin try unify env ty ty1 with Unify trace ->

2018

raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))

2019

end;

2020

ty1

2021

| Pexp_coerce (e, sty1, sty2) ->

2022

let approx_ty_opt = function

2023

| None -> newvar ()

2024

| Some sty -> approx_type env sty

2025

in

2026

let ty = type_approx env e

2027

and ty1 = approx_ty_opt sty1

2028

and ty2 = approx_type env sty2 in

2029

begin try unify env ty ty1 with Unify trace ->

2030

raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))

2031

end;

2032

ty2

2033

| _ -> newvar ()

2034

2035

(* List labels in a function type, and whether return type is a variable *)

2036

let rec list_labels_aux env visited ls ty_fun =

2037

let ty = expand_head env ty_fun in

2038

if List.memq ty visited then

2039

List.rev ls, false

2040

else match ty.desc with

2041

Tarrow (l, _, ty_res, _) ->

2042

list_labels_aux env (ty::visited) (l::ls) ty_res

2043

| _ ->

2044

List.rev ls, is_Tvar ty

2045

2046

let list_labels env ty =

2047

wrap_trace_gadt_instances env (list_labels_aux env [] []) ty

2048

2049

(* Check that all univars are safe in a type *)

2050

let check_univars env expans kind exp ty_expected vars =

2051

if expans && maybe_expansive exp then

2052

lower_contravariant env exp.exp_type;

2053

(* need to expand twice? cf. Ctype.unify2 *)

2054

let vars = List.map (expand_head env) vars in

2055

let vars = List.map (expand_head env) vars in

2056

let vars' =

2057

List.filter

2058

(fun t ->

2059

let t = repr t in

2060

generalize t;

2061

match t.desc with

2062

Tvar name when t.level = generic_level ->

2063

set_type_desc t (Tunivar name); true

2064

| _ -> false)

2065

vars in

2066

if List.length vars = List.length vars' then () else

2067

let ty = newgenty (Tpoly(repr exp.exp_type, vars'))

2068

and ty_expected = repr ty_expected in

2069

raise (Error (exp.exp_loc, env,

2070

Less_general(kind, [Unification_trace.diff ty ty_expected])))

2071

2072

let check_partial_application statement exp =

2073

let rec f delay =

2074

let ty = (expand_head exp.exp_env exp.exp_type).desc in

2075

let check_statement () =

2076

match ty with

2077

| Tconstr (p, _, _) when Path.same p Predef.path_unit ->

2078

()

2079

| _ ->

2080

if statement then

2081

let rec loop {exp_loc; exp_desc; exp_extra; _} =

2082

match exp_desc with

2083

| Texp_let (_, _, e)

2084

| Texp_sequence (_, e)

2085

| Texp_letexception (_, e)

2086

| Texp_letmodule (_, _, _, _, e) ->

2087

loop e

2088

| _ ->

2089

let loc =

2090

match List.find_opt (function

2091

| (Texp_constraint _, _, _) -> true

2092

| _ -> false) exp_extra

2093

with

2094

| Some (_, loc, _) -> loc

2095

| None -> exp_loc

2096

in

2097

Location.prerr_warning loc Warnings.Statement_type

2098

in

2099

loop exp

2100

in

2101

match ty, exp.exp_desc with

2102

| Tarrow _, _ ->

2103

let rec check {exp_desc; exp_loc; exp_extra; _} =

2104

if List.exists (function

2105

| (Texp_constraint _, _, _) -> true

2106

| _ -> false) exp_extra then check_statement ()

2107

else begin

2108

match exp_desc with

2109

| Texp_ident _ | Texp_constant _ | Texp_tuple _

2110

| Texp_construct _ | Texp_variant _ | Texp_record _

2111

| Texp_field _ | Texp_setfield _ | Texp_array _

2112

| Texp_while _ | Texp_for _ | Texp_instvar _

2113

| Texp_setinstvar _ | Texp_override _ | Texp_assert _

2114

| Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable

2115

| Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)

2116

| Texp_function _ ->

2117

check_statement ()

2118

| Texp_match (_, cases, _) ->

2119

List.iter (fun {c_rhs; _} -> check c_rhs) cases

2120

| Texp_try (e, cases) ->

2121

check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases

2122

| Texp_ifthenelse (_, e1, Some e2) ->

2123

check e1; check e2

2124

| Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)

2125

| Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->

2126

check e

2127

| Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->

2128

Location.prerr_warning exp_loc Warnings.Partial_application

2129

end

2130

in

2131

check exp

2132

| Tvar _, _ ->

2133

if delay then add_delayed_check (fun () -> f false)

2134

| _ ->

2135

check_statement ()

2136

in

2137

f true

2138

2139

(* Check that a type is generalizable at some level *)

2140

let generalizable level ty =

2141

let rec check ty =

2142

let ty = repr ty in

2143

if ty.level < lowest_level then () else

2144

if ty.level <= level then raise Exit else

2145

(mark_type_node ty; iter_type_expr check ty)

2146

in

2147

try check ty; unmark_type ty; true

2148

with Exit -> unmark_type ty; false

2149

2150

(* Hack to allow coercion of self. Will clean-up later. *)

2151

let self_coercion = ref ([] : (Path.t * Location.t list ref) list)

2152

2153

(* Helpers for packaged modules. *)

2154

let create_package_type loc env (p, l) =

2155

let s = !Typetexp.transl_modtype_longident loc env p in

2156

let fields = List.map (fun (name, ct) ->

2157

name, Typetexp.transl_simple_type env false ct) l in

2158

let ty = newty (Tpackage (s,

2159

List.map fst l,

2160

List.map (fun (_, cty) -> cty.ctyp_type) fields))

2161

in

2162

(s, fields, ty)

2163

2164

let wrap_unpacks sexp unpacks =

2165

let open Ast_helper in

2166

List.fold_left

2167

(fun sexp (name, loc) ->

2168

Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }

2169

~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]

2170

{ name with txt = Some name.txt }

2171

(Mod.unpack ~loc

2172

(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)

2173

name.loc)))

2174

sexp

2175

)

2176

sexp unpacks

2177

2178

(* Helpers for type_cases *)

2179

2180

let contains_variant_either ty =

2181

let rec loop ty =

2182

let ty = repr ty in

2183

if ty.level >= lowest_level then begin

2184

mark_type_node ty;

2185

match ty.desc with

2186

Tvariant row ->

2187

let row = row_repr row in

2188

if not (is_fixed row) then

2189

List.iter

2190

(fun (_,f) ->

2191

match row_field_repr f with Reither _ -> raise Exit | _ -> ())

2192

row.row_fields;

2193

iter_row loop row

2194

| _ ->

2195

iter_type_expr loop ty

2196

end

2197

in

2198

try loop ty; unmark_type ty; false

2199

with Exit -> unmark_type ty; true

2200

2201

let shallow_iter_ppat f p =

2202

match p.ppat_desc with

2203

| Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _

2204

| Ppat_extension _

2205

| Ppat_type _ | Ppat_unpack _ -> ()

2206

| Ppat_array pats -> List.iter f pats

2207

| Ppat_or (p1,p2) -> f p1; f p2

2208

| Ppat_variant (_, arg) | Ppat_construct (_, arg) -> Option.iter f arg

2209

| Ppat_tuple lst -> List.iter f lst

2210

| Ppat_exception p | Ppat_alias (p,_)

2211

| Ppat_open (_,p)

2212

| Ppat_constraint (p,_) | Ppat_lazy p -> f p

2213

| Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args

2214

2215

let exists_ppat f p =

2216

let exception Found in

2217

let rec loop p =

2218

if f p then raise Found else ();

2219

shallow_iter_ppat loop p in

2220

match loop p with

2221

| exception Found -> true

2222

| () -> false

2223

2224

let contains_polymorphic_variant p =

2225

exists_ppat

2226

(function

2227

| {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true

2228

| _ -> false)

2229

p

2230

2231

let contains_gadt cp =

2232

exists_pattern

2233

(function

2234

| {pat_desc = Tpat_construct (_, cd, _)} when cd.cstr_generalized -> true

2235

| _ -> false)

2236

cp

2237

2238

(* There are various things that we need to do in presence of GADT constructors

2239

that aren't required if there are none.

2240

However, because of disambiguation, we can't know for sure whether the

2241

patterns contain some GADT constructors. So we conservatively assume that

2242

any constructor might be a GADT constructor. *)

2243

let may_contain_gadts p =

2244

exists_ppat

2245

(function

2246

| {ppat_desc = Ppat_construct (_, _)} -> true

2247

| _ -> false)

2248

p

2249

2250

let check_absent_variant env =

2251

iter_pattern

2252

(function {pat_desc = Tpat_variant (s, arg, row)} as pat ->

2253

let row = row_repr !row in

2254

if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)

2255

row.row_fields

2256

|| not (is_fixed row) && not (static_row row) (* same as Ctype.poly *)

2257

then () else

2258

let ty_arg =

2259

match arg with None -> [] | Some p -> [correct_levels p.pat_type] in

2260

let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];

2261

row_more = newvar (); row_bound = ();

2262

row_closed = false; row_fixed = None; row_name = None} in

2263

(* Should fail *)

2264

unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}

2265

(correct_levels pat.pat_type)

2266

| _ -> ())

2267

2268

(* Getting proper location of already typed expressions.

2269

2270

Used to avoid confusing locations on type error messages in presence of

2271

type constraints.

2272

For example:

2273

2274

(* Before patch *)

2275

# let x : string = (5 : int);;

2276

^

2277

(* After patch *)

2278

# let x : string = (5 : int);;

2279

^^^^^^^^^

2280

*)

2281

let proper_exp_loc exp =

2282

let rec aux = function

2283

| [] -> exp.exp_loc

2284

| ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc

2285

| _ :: rest -> aux rest

2286

in

2287

aux exp.exp_extra

2288

2289

(* To find reasonable names for let-bound and lambda-bound idents *)

2290

2291

let rec name_pattern default = function

2292

[] -> Ident.create_local default

2293

| p :: rem ->

2294

match p.pat_desc with

2295

Tpat_var (id, _) -> id

2296

| Tpat_alias(_, id, _) -> id

2297

| _ -> name_pattern default rem

2298

2299

let name_cases default lst =

2300

name_pattern default (List.map (fun c -> c.c_lhs) lst)

2301

2302

(* Typing of expressions *)

2303

2304

let unify_exp env exp expected_ty =

2305

let loc = proper_exp_loc exp in

2306

try

2307

unify_exp_types loc env exp.exp_type expected_ty

2308

with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->

2309

raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))

2310

2311

let rec type_exp ?recarg env sexp =

2312

(* We now delegate everything to type_expect *)

2313

type_expect ?recarg env sexp (mk_expected (newvar ()))

2314

2315

(* Typing of an expression with an expected type.

2316

This provide better error messages, and allows controlled

2317

propagation of return type information.

2318

In the principal case, [type_expected'] may be at generic_level.

2319

*)

2320

2321

and type_expect ?in_function ?recarg env sexp ty_expected_explained =

2322

let previous_saved_types = Cmt_format.get_saved_types () in

2323

let exp =

2324

Builtin_attributes.warning_scope sexp.pexp_attributes

2325

(fun () ->

2326

type_expect_ ?in_function ?recarg env sexp ty_expected_explained

2327

)

2328

in

2329

Cmt_format.set_saved_types

2330

(Cmt_format.Partial_expression exp :: previous_saved_types);

2331

exp

2332

2333

and with_explanation explanation f =

2334

match explanation with

2335

| None -> f ()

2336

| Some explanation ->

2337

try f ()

2338

with Error (loc', env', Expr_type_clash(trace', None, exp'))

2339

when not loc'.Location.loc_ghost ->

2340

let err = Expr_type_clash(trace', Some explanation, exp') in

2341

raise (Error (loc', env', err))

2342

2343

and type_expect_

2344

?in_function ?(recarg=Rejected)

2345

env sexp ty_expected_explained =

2346

let { ty = ty_expected; explanation } = ty_expected_explained in

2347

let loc = sexp.pexp_loc in

2348

(* Record the expression type before unifying it with the expected type *)

2349

let with_explanation = with_explanation explanation in

2350

let rue exp =

2351

with_explanation (fun () ->

2352

unify_exp env (re exp) (instance ty_expected));

2353

exp

2354

in

2355

match sexp.pexp_desc with

2356

| Pexp_ident lid ->

2357

let path, desc = type_ident env ~recarg lid in

2358

let exp_desc =

2359

match desc.val_kind with

2360

| Val_ivar (_, cl_num) ->

2361

let (self_path, _) =

2362

Env.find_value_by_name

2363

(Longident.Lident ("self-" ^ cl_num)) env

2364

in

2365

Texp_instvar(self_path, path,

2366

match lid.txt with

2367

Longident.Lident txt -> { txt; loc = lid.loc }

2368

| _ -> assert false)

2369

| Val_self (_, _, cl_num, _) ->

2370

let (path, _) =

2371

Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env

2372

in

2373

Texp_ident(path, lid, desc)

2374

| _ ->

2375

Texp_ident(path, lid, desc)

2376

in

2377

rue {

2378

exp_desc; exp_loc = loc; exp_extra = [];

2379

exp_type = instance desc.val_type;

2380

exp_attributes = sexp.pexp_attributes;

2381

exp_env = env }

2382

| Pexp_constant(Pconst_string (str, _) as cst) -> (

2383

let cst = constant_or_raise env loc cst in

2384

(* Terrible hack for format strings *)

2385

let ty_exp = expand_head env ty_expected in

2386

let fmt6_path =

2387

Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),

2388

"format6"))

2389

in

2390

let is_format = match ty_exp.desc with

2391

| Tconstr(path, _, _) when Path.same path fmt6_path ->

2392

if !Clflags.principal && ty_exp.level <> generic_level then

2393

Location.prerr_warning loc

2394

(Warnings.Not_principal "this coercion to format6");

2395

true

2396

| _ -> false

2397

in

2398

if is_format then

2399

let format_parsetree =

2400

{ (type_format loc str env) with pexp_loc = sexp.pexp_loc } in

2401

type_expect ?in_function env format_parsetree ty_expected_explained

2402

else

2403

rue {

2404

exp_desc = Texp_constant cst;

2405

exp_loc = loc; exp_extra = [];

2406

exp_type = instance Predef.type_string;

2407

exp_attributes = sexp.pexp_attributes;

2408

exp_env = env }

2409

)

2410

| Pexp_constant cst ->

2411

let cst = constant_or_raise env loc cst in

2412

rue {

2413

exp_desc = Texp_constant cst;

2414

exp_loc = loc; exp_extra = [];

2415

exp_type = type_constant cst;

2416

exp_attributes = sexp.pexp_attributes;

2417

exp_env = env }

2418

| Pexp_let(Nonrecursive,

2419

[{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)

2420

when may_contain_gadts spat ->

2421

(* TODO: allow non-empty attributes? *)

2422

type_expect ?in_function env

2423

{sexp with

2424

pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}

2425

ty_expected_explained

2426

| Pexp_let(rec_flag, spat_sexp_list, sbody) ->

2427

let existential_context =

2428

if rec_flag = Recursive then In_rec

2429

else if List.compare_length_with spat_sexp_list 1 > 0 then In_group

2430

else With_attributes in

2431

let scp =

2432

match sexp.pexp_attributes, rec_flag with

2433

| [{attr_name = {txt="#default"}; _}], _ -> None

2434

| _, Recursive -> Some (Annot.Idef loc)

2435

| _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)

2436

in

2437

let (pat_exp_list, new_env, unpacks) =

2438

type_let existential_context env rec_flag spat_sexp_list scp true in

2439

let body =

2440

type_expect new_env (wrap_unpacks sbody unpacks)

2441

ty_expected_explained in

2442

let () =

2443

if rec_flag = Recursive then

2444

check_recursive_bindings env pat_exp_list

2445

in

2446

re {

2447

exp_desc = Texp_let(rec_flag, pat_exp_list, body);

2448

exp_loc = loc; exp_extra = [];

2449

exp_type = body.exp_type;

2450

exp_attributes = sexp.pexp_attributes;

2451

exp_env = env }

2452

| Pexp_fun (l, Some default, spat, sbody) ->

2453

assert(is_optional l); (* default allowed only with optional argument *)

2454

let open Ast_helper in

2455

let default_loc = default.pexp_loc in

2456

let scases = [

2457

Exp.case

2458

(Pat.construct ~loc:default_loc

2459

(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))

2460

(Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))

2461

(Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));

2462

2463

Exp.case

2464

(Pat.construct ~loc:default_loc

2465

(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))

2466

None)

2467

default;

2468

]

2469

in

2470

let sloc =

2471

{ Location.loc_start = spat.ppat_loc.Location.loc_start;

2472

loc_end = default_loc.Location.loc_end;

2473

loc_ghost = true }

2474

in

2475

let smatch =

2476

Exp.match_ ~loc:sloc

2477

(Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))

2478

scases

2479

in

2480

let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in

2481

let body =

2482

Exp.let_ ~loc Nonrecursive

2483

~attrs:[Attr.mk (mknoloc "#default") (PStr [])]

2484

[Vb.mk spat smatch] sbody

2485

in

2486

type_function ?in_function loc sexp.pexp_attributes env

2487

ty_expected_explained l [Exp.case pat body]

2488

| Pexp_fun (l, None, spat, sbody) ->

2489

type_function ?in_function loc sexp.pexp_attributes env

2490

ty_expected_explained l [Ast_helper.Exp.case spat sbody]

2491

| Pexp_function caselist ->

2492

type_function ?in_function

2493

loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist

2494

| Pexp_apply(sfunct, sargs) ->

2495

assert (sargs <> []);

2496

begin_def (); (* one more level for non-returning functions *)

2497

if !Clflags.principal then begin_def ();

2498

let funct = type_exp env sfunct in

2499

if !Clflags.principal then begin

2500

end_def ();

2501

generalize_structure funct.exp_type

2502

end;

2503

let rec lower_args seen ty_fun =

2504

let ty = expand_head env ty_fun in

2505

if List.memq ty seen then () else

2506

match ty.desc with

2507

Tarrow (_l, ty_arg, ty_fun, _com) ->

2508

(try unify_var env (newvar()) ty_arg with Unify _ -> assert false);

2509

lower_args (ty::seen) ty_fun

2510

| _ -> ()

2511

in

2512

let ty = instance funct.exp_type in

2513

end_def ();

2514

wrap_trace_gadt_instances env (lower_args []) ty;

2515

begin_def ();

2516

let (args, ty_res) = type_application env funct sargs in

2517

end_def ();

2518

unify_var env (newvar()) funct.exp_type;

2519

rue {

2520

exp_desc = Texp_apply(funct, args);

2521

exp_loc = loc; exp_extra = [];

2522

exp_type = ty_res;

2523

exp_attributes = sexp.pexp_attributes;

2524

exp_env = env }

2525

| Pexp_match(sarg, caselist) ->

2526

begin_def ();

2527

let arg = type_exp env sarg in

2528

end_def ();

2529

if maybe_expansive arg then lower_contravariant env arg.exp_type;

2530

generalize arg.exp_type;

2531

let cases, partial =

2532

type_cases ~exception_allowed:true env arg.exp_type ty_expected true loc

2533

caselist

2534

in

2535

re {

2536

exp_desc = Texp_match(arg, cases, partial);

2537

exp_loc = loc; exp_extra = [];

2538

exp_type = instance ty_expected;

2539

exp_attributes = sexp.pexp_attributes;

2540

exp_env = env }

2541

| Pexp_try(sbody, caselist) ->

2542

let body = type_expect env sbody ty_expected_explained in

2543

let cases, _ =

2544

type_cases env Predef.type_exn ty_expected false loc caselist in

2545

re {

2546

exp_desc = Texp_try(body, cases);

2547

exp_loc = loc; exp_extra = [];

2548

exp_type = body.exp_type;

2549

exp_attributes = sexp.pexp_attributes;

2550

exp_env = env }

2551

| Pexp_tuple sexpl ->

2552

assert (List.length sexpl >= 2);

2553

let subtypes = List.map (fun _ -> newgenvar ()) sexpl in

2554

let to_unify = newgenty (Ttuple subtypes) in

2555

with_explanation (fun () ->

2556

unify_exp_types loc env to_unify ty_expected);

2557

let expl =

2558

List.map2 (fun body ty -> type_expect env body (mk_expected ty))

2559

sexpl subtypes

2560

in

2561

re {

2562

exp_desc = Texp_tuple expl;

2563

exp_loc = loc; exp_extra = [];

2564

(* Keep sharing *)

2565

exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));

2566

exp_attributes = sexp.pexp_attributes;

2567

exp_env = env }

2568

| Pexp_construct(lid, sarg) ->

2569

type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes

2570

| Pexp_variant(l, sarg) ->

2571

(* Keep sharing *)

2572

let ty_expected0 = instance ty_expected in

2573

begin try match

2574

sarg, expand_head env ty_expected, expand_head env ty_expected0 with

2575

| Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->

2576

let row = row_repr row in

2577

begin match row_field_repr (List.assoc l row.row_fields),

2578

row_field_repr (List.assoc l row0.row_fields) with

2579

Rpresent (Some ty), Rpresent (Some ty0) ->

2580

let arg = type_argument env sarg ty ty0 in

2581

re { exp_desc = Texp_variant(l, Some arg);

2582

exp_loc = loc; exp_extra = [];

2583

exp_type = ty_expected0;

2584

exp_attributes = sexp.pexp_attributes;

2585

exp_env = env }

2586

| _ -> raise Not_found

2587

end

2588

| _ -> raise Not_found

2589

with Not_found ->

2590

let arg = Option.map (type_exp env) sarg in

2591

let arg_type = Option.map (fun arg -> arg.exp_type) arg in

2592

rue {

2593

exp_desc = Texp_variant(l, arg);

2594

exp_loc = loc; exp_extra = [];

2595

exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];

2596

row_more = newvar ();

2597

row_bound = ();

2598

row_closed = false;

2599

row_fixed = None;

2600

row_name = None});

2601

exp_attributes = sexp.pexp_attributes;

2602

exp_env = env }

2603

end

2604

| Pexp_record(lid_sexp_list, opt_sexp) ->

2605

assert (lid_sexp_list <> []);

2606

let opt_exp =

2607

match opt_sexp with

2608

None -> None

2609

| Some sexp ->

2610

if !Clflags.principal then begin_def ();

2611

let exp = type_exp ~recarg env sexp in

2612

if !Clflags.principal then begin

2613

end_def ();

2614

generalize_structure exp.exp_type

2615

end;

2616

Some exp

2617

in

2618

let ty_record, opath =

2619

let get_path ty =

2620

try

2621

let (p0, p,_) = extract_concrete_record env ty in

2622

let principal =

2623

(repr ty).level = generic_level || not !Clflags.principal

2624

in

2625

Some (p0, p, principal)

2626

with Not_found -> None

2627

in

2628

match get_path ty_expected with

2629

None ->

2630

begin match opt_exp with

2631

None -> newvar (), None

2632

| Some exp ->

2633

match get_path exp.exp_type with

2634

None -> newvar (), None

2635

| Some (_, p', _) as op ->

2636

let decl = Env.find_type p' env in

2637

begin_def ();

2638

let ty =

2639

newconstr p' (instance_list decl.type_params) in

2640

end_def ();

2641

generalize_structure ty;

2642

ty, op

2643

end

2644

| op -> ty_expected, op

2645

in

2646

let closed = (opt_sexp = None) in

2647

let lbl_exp_list =

2648

wrap_disambiguate "This record expression is expected to have"

2649

(mk_expected ty_record)

2650

(type_label_a_list loc closed env

2651

(fun e k -> k (type_label_exp true env loc ty_record e))

2652

opath lid_sexp_list)

2653

(fun x -> x)

2654

in

2655

with_explanation (fun () ->

2656

unify_exp_types loc env ty_record (instance ty_expected));

2657

2658

(* type_label_a_list returns a list of labels sorted by lbl_pos *)

2659

(* note: check_duplicates would better be implemented in

2660

type_label_a_list directly *)

2661

let rec check_duplicates = function

2662

| (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->

2663

raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))

2664

| _ :: rem ->

2665

check_duplicates rem

2666

| [] -> ()

2667

in

2668

check_duplicates lbl_exp_list;

2669

let opt_exp, label_definitions =

2670

let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in

2671

let matching_label lbl =

2672

List.find

2673

(fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)

2674

lbl_exp_list

2675

in

2676

match opt_exp with

2677

None ->

2678

let label_definitions =

2679

Array.map (fun lbl ->

2680

match matching_label lbl with

2681

| (lid, _lbl, lbl_exp) ->

2682

Overridden (lid, lbl_exp)

2683

| exception Not_found ->

2684

let present_indices =

2685

List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list

2686

in

2687

let label_names = extract_label_names env ty_expected in

2688

let rec missing_labels n = function

2689

[] -> []

2690

| lbl :: rem ->

2691

if List.mem n present_indices

2692

then missing_labels (n + 1) rem

2693

else lbl :: missing_labels (n + 1) rem

2694

in

2695

let missing = missing_labels 0 label_names in

2696

raise(Error(loc, env, Label_missing missing)))

2697

lbl.lbl_all

2698

in

2699

None, label_definitions

2700

| Some exp ->

2701

let ty_exp = instance exp.exp_type in

2702

let unify_kept lbl =

2703

let _, ty_arg1, ty_res1 = instance_label false lbl in

2704

unify_exp_types exp.exp_loc env ty_exp ty_res1;

2705

match matching_label lbl with

2706

| lid, _lbl, lbl_exp ->

2707

(* do not connect result types for overridden labels *)

2708

Overridden (lid, lbl_exp)

2709

| exception Not_found -> begin

2710

let _, ty_arg2, ty_res2 = instance_label false lbl in

2711

unify_exp_types loc env ty_arg1 ty_arg2;

2712

with_explanation (fun () ->

2713

unify_exp_types loc env (instance ty_expected) ty_res2);

2714

Kept ty_arg1

2715

end

2716

in

2717

let label_definitions = Array.map unify_kept lbl.lbl_all in

2718

Some {exp with exp_type = ty_exp}, label_definitions

2719

in

2720

let num_fields =

2721

match lbl_exp_list with [] -> assert false

2722

| (_, lbl,_)::_ -> Array.length lbl.lbl_all in

2723

let opt_exp =

2724

if opt_sexp <> None && List.length lid_sexp_list = num_fields then

2725

(Location.prerr_warning loc Warnings.Useless_record_with; None)

2726

else opt_exp

2727

in

2728

let label_descriptions, representation =

2729

let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in

2730

lbl_all, lbl_repres

2731

in

2732

let fields =

2733

Array.map2 (fun descr def -> descr, def)

2734

label_descriptions label_definitions

2735

in

2736

re {

2737

exp_desc = Texp_record {

2738

fields; representation;

2739

extended_expression = opt_exp

2740

};

2741

exp_loc = loc; exp_extra = [];

2742

exp_type = instance ty_expected;

2743

exp_attributes = sexp.pexp_attributes;

2744

exp_env = env }

2745

| Pexp_field(srecord, lid) ->

2746

let (record, label, _) = type_label_access env srecord lid in

2747

let (_, ty_arg, ty_res) = instance_label false label in

2748

unify_exp env record ty_res;

2749

rue {

2750

exp_desc = Texp_field(record, lid, label);

2751

exp_loc = loc; exp_extra = [];

2752

exp_type = ty_arg;

2753

exp_attributes = sexp.pexp_attributes;

2754

exp_env = env }

2755

| Pexp_setfield(srecord, lid, snewval) ->

2756

let (record, label, opath) = type_label_access env srecord lid in

2757

let ty_record = if opath = None then newvar () else record.exp_type in

2758

let (label_loc, label, newval) =

2759

type_label_exp false env loc ty_record (lid, label, snewval) in

2760

unify_exp env record ty_record;

2761

if label.lbl_mut = Immutable then

2762

raise(Error(loc, env, Label_not_mutable lid.txt));

2763

rue {

2764

exp_desc = Texp_setfield(record, label_loc, label, newval);

2765

exp_loc = loc; exp_extra = [];

2766

exp_type = instance Predef.type_unit;

2767

exp_attributes = sexp.pexp_attributes;

2768

exp_env = env }

2769

| Pexp_array(sargl) ->

2770

let ty = newgenvar() in

2771

let to_unify = Predef.type_array ty in

2772

with_explanation (fun () ->

2773

unify_exp_types loc env to_unify ty_expected);

2774

let argl =

2775

List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in

2776

re {

2777

exp_desc = Texp_array argl;

2778

exp_loc = loc; exp_extra = [];

2779

exp_type = instance ty_expected;

2780

exp_attributes = sexp.pexp_attributes;

2781

exp_env = env }

2782

| Pexp_ifthenelse(scond, sifso, sifnot) ->

2783

let cond = type_expect env scond

2784

(mk_expected ~explanation:If_conditional Predef.type_bool) in

2785

begin match sifnot with

2786

None ->

2787

let ifso = type_expect env sifso

2788

(mk_expected ~explanation:If_no_else_branch Predef.type_unit) in

2789

rue {

2790

exp_desc = Texp_ifthenelse(cond, ifso, None);

2791

exp_loc = loc; exp_extra = [];

2792

exp_type = ifso.exp_type;

2793

exp_attributes = sexp.pexp_attributes;

2794

exp_env = env }

2795

| Some sifnot ->

2796

let ifso = type_expect env sifso ty_expected_explained in

2797

let ifnot = type_expect env sifnot ty_expected_explained in

2798

(* Keep sharing *)

2799

unify_exp env ifnot ifso.exp_type;

2800

re {

2801

exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);

2802

exp_loc = loc; exp_extra = [];

2803

exp_type = ifso.exp_type;

2804

exp_attributes = sexp.pexp_attributes;

2805

exp_env = env }

2806

end

2807

| Pexp_sequence(sexp1, sexp2) ->

2808

let exp1 = type_statement ~explanation:Sequence_left_hand_side

2809

env sexp1 in

2810

let exp2 = type_expect env sexp2 ty_expected_explained in

2811

re {

2812

exp_desc = Texp_sequence(exp1, exp2);

2813

exp_loc = loc; exp_extra = [];

2814

exp_type = exp2.exp_type;

2815

exp_attributes = sexp.pexp_attributes;

2816

exp_env = env }

2817

| Pexp_while(scond, sbody) ->

2818

let cond = type_expect env scond

2819

(mk_expected ~explanation:While_loop_conditional Predef.type_bool) in

2820

let body = type_statement ~explanation:While_loop_body env sbody in

2821

rue {

2822

exp_desc = Texp_while(cond, body);

2823

exp_loc = loc; exp_extra = [];

2824

exp_type = instance Predef.type_unit;

2825

exp_attributes = sexp.pexp_attributes;

2826

exp_env = env }

2827

| Pexp_for(param, slow, shigh, dir, sbody) ->

2828

let low = type_expect env slow

2829

(mk_expected ~explanation:For_loop_start_index Predef.type_int) in

2830

let high = type_expect env shigh

2831

(mk_expected ~explanation:For_loop_stop_index Predef.type_int) in

2832

let id, new_env =

2833

match param.ppat_desc with

2834

| Ppat_any -> Ident.create_local "_for", env

2835

| Ppat_var {txt} ->

2836

Env.enter_value txt {val_type = instance Predef.type_int;

2837

val_attributes = [];

2838

val_kind = Val_reg; Types.val_loc = loc; } env

2839

~check:(fun s -> Warnings.Unused_for_index s)

2840

| _ ->

2841

raise (Error (param.ppat_loc, env, Invalid_for_loop_index))

2842

in

2843

let body = type_statement ~explanation:For_loop_body new_env sbody in

2844

rue {

2845

exp_desc = Texp_for(id, param, low, high, dir, body);

2846

exp_loc = loc; exp_extra = [];

2847

exp_type = instance Predef.type_unit;

2848

exp_attributes = sexp.pexp_attributes;

2849

exp_env = env }

2850

| Pexp_constraint (sarg, sty) ->

2851

(* Pretend separate = true, 1% slowdown for lablgtk *)

2852

begin_def ();

2853

let cty = Typetexp.transl_simple_type env false sty in

2854

let ty = cty.ctyp_type in

2855

end_def ();

2856

generalize_structure ty;

2857

let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in

2858

rue {

2859

exp_desc = arg.exp_desc;

2860

exp_loc = arg.exp_loc;

2861

exp_type = ty';

2862

exp_attributes = arg.exp_attributes;

2863

exp_env = env;

2864

exp_extra =

2865

(Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;

2866

}

2867

| Pexp_coerce(sarg, sty, sty') ->

2868

(* Pretend separate = true, 1% slowdown for lablgtk *)

2869

(* Also see PR#7199 for a problem with the following:

2870

let separate = !Clflags.principal || Env.has_local_constraints env in*)

2871

let (arg, ty',cty,cty') =

2872

match sty with

2873

| None ->

2874

let (cty', force) =

2875

Typetexp.transl_simple_type_delayed env sty'

2876

in

2877

let ty' = cty'.ctyp_type in

2878

begin_def ();

2879

let arg = type_exp env sarg in

2880

end_def ();

2881

let tv = newvar () in

2882

let gen = generalizable tv.level arg.exp_type in

2883

unify_var env tv arg.exp_type;

2884

begin match arg.exp_desc, !self_coercion, (repr ty').desc with

2885

Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,

2886

Tconstr(path',_,_) when Path.same path path' ->

2887

(* prerr_endline "self coercion"; *)

2888

r := loc :: !r;

2889

force ()

2890

| _ when free_variables ~env arg.exp_type = []

2891

&& free_variables ~env ty' = [] ->

2892

if not gen && (* first try a single coercion *)

2893

let snap = snapshot () in

2894

let ty, _b = enlarge_type env ty' in

2895

try

2896

force (); Ctype.unify env arg.exp_type ty; true

2897

with Unify _ ->

2898

backtrack snap; false

2899

then ()

2900

else begin try

2901

let force' = subtype env arg.exp_type ty' in

2902

force (); force' ();

2903

if not gen && !Clflags.principal then

2904

Location.prerr_warning loc

2905

(Warnings.Not_principal "this ground coercion");

2906

with Subtype (tr1, tr2) ->

2907

(* prerr_endline "coercion failed"; *)

2908

raise(Error(loc, env, Not_subtype(tr1, tr2)))

2909

end;

2910

| _ ->

2911

let ty, b = enlarge_type env ty' in

2912

force ();

2913

begin try Ctype.unify env arg.exp_type ty with Unify trace ->

2914

raise(Error(sarg.pexp_loc, env,

2915

Coercion_failure(ty', full_expand env ty', trace, b)))

2916

end

2917

end;

2918

(arg, ty', None, cty')

2919

| Some sty ->

2920

begin_def ();

2921

let (cty, force) =

2922

Typetexp.transl_simple_type_delayed env sty

2923

and (cty', force') =

2924

Typetexp.transl_simple_type_delayed env sty'

2925

in

2926

let ty = cty.ctyp_type in

2927

let ty' = cty'.ctyp_type in

2928

begin try

2929

let force'' = subtype env ty ty' in

2930

force (); force' (); force'' ()

2931

with Subtype (tr1, tr2) ->

2932

raise(Error(loc, env, Not_subtype(tr1, tr2)))

2933

end;

2934

end_def ();

2935

generalize_structure ty;

2936

generalize_structure ty';

2937

(type_argument env sarg ty (instance ty),

2938

instance ty', Some cty, cty')

2939

in

2940

rue {

2941

exp_desc = arg.exp_desc;

2942

exp_loc = arg.exp_loc;

2943

exp_type = ty';

2944

exp_attributes = arg.exp_attributes;

2945

exp_env = env;

2946

exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::

2947

arg.exp_extra;

2948

}

2949

| Pexp_send (e, {txt=met}) ->

2950

if !Clflags.principal then begin_def ();

2951

let obj = type_exp env e in

2952

let obj_meths = ref None in

2953

begin try

2954

let (meth, exp, typ) =

2955

match obj.exp_desc with

2956

Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->

2957

obj_meths := Some meths;

2958

let (id, typ) =

2959

filter_self_method env met Private meths privty

2960

in

2961

if is_Tvar (repr typ) then

2962

Location.prerr_warning loc

2963

(Warnings.Undeclared_virtual_method met);

2964

(Tmeth_val id, None, typ)

2965

| Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->

2966

let method_id =

2967

begin try List.assoc met methods with Not_found ->

2968

let valid_methods = List.map fst methods in

2969

raise(Error(e.pexp_loc, env,

2970

Undefined_inherited_method (met, valid_methods)))

2971

end

2972

in

2973

begin match

2974

Env.find_value_by_name

2975

(Longident.Lident ("selfpat-" ^ cl_num)) env,

2976

Env.find_value_by_name

2977

(Longident.Lident ("self-" ^cl_num)) env

2978

with

2979

| (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),

2980

(path, _) ->

2981

obj_meths := Some meths;

2982

let (_, typ) =

2983

filter_self_method env met Private meths privty

2984

in

2985

let method_type = newvar () in

2986

let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in

2987

unify env obj_ty desc.val_type;

2988

unify env res_ty (instance typ);

2989

let method_desc =

2990

{val_type = method_type;

2991

val_kind = Val_reg;

2992

val_attributes = [];

2993

Types.val_loc = Location.none}

2994

in

2995

let exp_env = Env.add_value method_id method_desc env in

2996

let exp =

2997

Texp_apply({exp_desc =

2998

Texp_ident(Path.Pident method_id,

2999

lid, method_desc);

3000

exp_loc = loc; exp_extra = [];

3001

exp_type = method_type;

3002

exp_attributes = []; (* check *)

3003

exp_env = exp_env},

3004

[ Nolabel,

3005

Some {exp_desc = Texp_ident(path, lid, desc);

3006

exp_loc = obj.exp_loc; exp_extra = [];

3007

exp_type = desc.val_type;

3008

exp_attributes = []; (* check *)

3009

exp_env = exp_env}

3010

])

3011

in

3012

(Tmeth_name met, Some (re {exp_desc = exp;

3013

exp_loc = loc; exp_extra = [];

3014

exp_type = typ;

3015

exp_attributes = []; (* check *)

3016

exp_env = exp_env}), typ)

3017

| _ ->

3018

assert false

3019

end

3020

| _ ->

3021

(Tmeth_name met, None,

3022

filter_method env met Public obj.exp_type)

3023

in

3024

if !Clflags.principal then begin

3025

end_def ();

3026

generalize_structure typ;

3027

end;

3028

let typ =

3029

match repr typ with

3030

{desc = Tpoly (ty, [])} ->

3031

instance ty

3032

| {desc = Tpoly (ty, tl); level = l} ->

3033

if !Clflags.principal && l <> generic_level then

3034

Location.prerr_warning loc

3035

(Warnings.Not_principal "this use of a polymorphic method");

3036

snd (instance_poly false tl ty)

3037

| {desc = Tvar _} as ty ->

3038

let ty' = newvar () in

3039

unify env (instance ty) (newty(Tpoly(ty',[])));

3040

(* if not !Clflags.nolabels then

3041

Location.prerr_warning loc (Warnings.Unknown_method met); *)

3042

ty'

3043

| _ ->

3044

assert false

3045

in

3046

rue {

3047

exp_desc = Texp_send(obj, meth, exp);

3048

exp_loc = loc; exp_extra = [];

3049

exp_type = typ;

3050

exp_attributes = sexp.pexp_attributes;

3051

exp_env = env }

3052

with Unify _ ->

3053

let valid_methods =

3054

match !obj_meths with

3055

| Some meths ->

3056

Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])

3057

| None ->

3058

match (expand_head env obj.exp_type).desc with

3059

| Tobject (fields, _) ->

3060

let (fields, _) = Ctype.flatten_fields fields in

3061

let collect_fields li (meth, meth_kind, _meth_ty) =

3062

if meth_kind = Fpresent then meth::li else li in

3063

Some (List.fold_left collect_fields [] fields)

3064

| _ -> None

3065

in

3066

raise(Error(e.pexp_loc, env,

3067

Undefined_method (obj.exp_type, met, valid_methods)))

3068

end

3069

| Pexp_new cl ->

3070

let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in

3071

begin match cl_decl.cty_new with

3072

None ->

3073

raise(Error(loc, env, Virtual_class cl.txt))

3074

| Some ty ->

3075

rue {

3076

exp_desc = Texp_new (cl_path, cl, cl_decl);

3077

exp_loc = loc; exp_extra = [];

3078

exp_type = instance ty;

3079

exp_attributes = sexp.pexp_attributes;

3080

exp_env = env }

3081

end

3082

| Pexp_setinstvar (lab, snewval) -> begin

3083

let (path, mut, cl_num, ty) =

3084

Env.lookup_instance_variable ~loc lab.txt env

3085

in

3086

match mut with

3087

| Mutable ->

3088

let newval =

3089

type_expect env snewval (mk_expected (instance ty))

3090

in

3091

let (path_self, _) =

3092

Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env

3093

in

3094

rue {

3095

exp_desc = Texp_setinstvar(path_self, path, lab, newval);

3096

exp_loc = loc; exp_extra = [];

3097

exp_type = instance Predef.type_unit;

3098

exp_attributes = sexp.pexp_attributes;

3099

exp_env = env }

3100

| _ ->

3101

raise(Error(loc, env, Instance_variable_not_mutable lab.txt))

3102

end

3103

| Pexp_override lst ->

3104

let _ =

3105

List.fold_right

3106

(fun (lab, _) l ->

3107

if List.exists (fun l -> l.txt = lab.txt) l then

3108

raise(Error(loc, env,

3109

Value_multiply_overridden lab.txt));

3110

lab::l)

3111

lst

3112

[] in

3113

begin match

3114

try

3115

Env.find_value_by_name (Longident.Lident "selfpat-*") env,

3116

Env.find_value_by_name (Longident.Lident "self-*") env

3117

with Not_found ->

3118

raise(Error(loc, env, Outside_class))

3119

with

3120

(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),

3121

(path_self, _) ->

3122

let type_override (lab, snewval) =

3123

begin try

3124

let (id, _, _, ty) = Vars.find lab.txt !vars in

3125

(Path.Pident id, lab,

3126

type_expect env snewval (mk_expected (instance ty)))

3127

with

3128

Not_found ->

3129

let vars = Vars.fold (fun var _ li -> var::li) !vars [] in

3130

raise(Error(loc, env,

3131

Unbound_instance_variable (lab.txt, vars)))

3132

end

3133

in

3134

let modifs = List.map type_override lst in

3135

rue {

3136

exp_desc = Texp_override(path_self, modifs);

3137

exp_loc = loc; exp_extra = [];

3138

exp_type = self_ty;

3139

exp_attributes = sexp.pexp_attributes;

3140

exp_env = env }

3141

| _ ->

3142

assert false

3143

end

3144

| Pexp_letmodule(name, smodl, sbody) ->

3145

let ty = newvar() in

3146

(* remember original level *)

3147

begin_def ();

3148

let context = Typetexp.narrow () in

3149

let modl = !type_module env smodl in

3150

Mtype.lower_nongen ty.level modl.mod_type;

3151

let pres =

3152

match modl.mod_type with

3153

| Mty_alias _ -> Mp_absent

3154

| _ -> Mp_present

3155

in

3156

let scope = create_scope () in

3157

let md =

3158

{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }

3159

in

3160

let (id, new_env) =

3161

match name.txt with

3162

| None -> None, env

3163

| Some name ->

3164

let id, env = Env.enter_module_declaration ~scope name pres md env in

3165

Some id, env

3166

in

3167

Typetexp.widen context;

3168

(* ideally, we should catch Expr_type_clash errors

3169

in type_expect triggered by escaping identifiers from the local module

3170

and refine them into Scoping_let_module errors

3171

*)

3172

let body = type_expect new_env sbody ty_expected_explained in

3173

(* go back to original level *)

3174

end_def ();

3175

Ctype.unify_var new_env ty body.exp_type;

3176

re {

3177

exp_desc = Texp_letmodule(id, name, pres, modl, body);

3178

exp_loc = loc; exp_extra = [];

3179

exp_type = ty;

3180

exp_attributes = sexp.pexp_attributes;

3181

exp_env = env }

3182

| Pexp_letexception(cd, sbody) ->

3183

let (cd, newenv) = Typedecl.transl_exception env cd in

3184

let body = type_expect newenv sbody ty_expected_explained in

3185

re {

3186

exp_desc = Texp_letexception(cd, body);

3187

exp_loc = loc; exp_extra = [];

3188

exp_type = body.exp_type;

3189

exp_attributes = sexp.pexp_attributes;

3190

exp_env = env }

3191

3192

| Pexp_assert (e) ->

3193

let cond = type_expect env e

3194

(mk_expected ~explanation:Assert_condition Predef.type_bool) in

3195

let exp_type =

3196

match cond.exp_desc with

3197

| Texp_construct(_, {cstr_name="false"}, _) ->

3198

instance ty_expected

3199

| _ ->

3200

instance Predef.type_unit

3201

in

3202

rue {

3203

exp_desc = Texp_assert cond;

3204

exp_loc = loc; exp_extra = [];

3205

exp_type;

3206

exp_attributes = sexp.pexp_attributes;

3207

exp_env = env;

3208

}

3209

| Pexp_lazy e ->

3210

let ty = newgenvar () in

3211

let to_unify = Predef.type_lazy_t ty in

3212

with_explanation (fun () ->

3213

unify_exp_types loc env to_unify ty_expected);

3214

let arg = type_expect env e (mk_expected ty) in

3215

re {

3216

exp_desc = Texp_lazy arg;

3217

exp_loc = loc; exp_extra = [];

3218

exp_type = instance ty_expected;

3219

exp_attributes = sexp.pexp_attributes;

3220

exp_env = env;

3221

}

3222

| Pexp_object s ->

3223

let desc, sign, meths = !type_object env loc s in

3224

rue {

3225

exp_desc = Texp_object (desc, (*sign,*) meths);

3226

exp_loc = loc; exp_extra = [];

3227

exp_type = sign.csig_self;

3228

exp_attributes = sexp.pexp_attributes;

3229

exp_env = env;

3230

}

3231

| Pexp_poly(sbody, sty) ->

3232

if !Clflags.principal then begin_def ();

3233

let ty, cty =

3234

match sty with None -> repr ty_expected, None

3235

| Some sty ->

3236

let sty = Ast_helper.Typ.force_poly sty in

3237

let cty = Typetexp.transl_simple_type env false sty in

3238

repr cty.ctyp_type, Some cty

3239

in

3240

if !Clflags.principal then begin

3241

end_def ();

3242

generalize_structure ty

3243

end;

3244

if sty <> None then

3245

with_explanation (fun () ->

3246

unify_exp_types loc env (instance ty) (instance ty_expected));

3247

let exp =

3248

match (expand_head env ty).desc with

3249

Tpoly (ty', []) ->

3250

let exp = type_expect env sbody (mk_expected ty') in

3251

{ exp with exp_type = instance ty }

3252

| Tpoly (ty', tl) ->

3253

(* One more level to generalize locally *)

3254

begin_def ();

3255

if !Clflags.principal then begin_def ();

3256

let vars, ty'' = instance_poly true tl ty' in

3257

if !Clflags.principal then begin

3258

end_def ();

3259

generalize_structure ty''

3260

end;

3261

let exp = type_expect env sbody (mk_expected ty'') in

3262

end_def ();

3263

check_univars env false "method" exp ty_expected vars;

3264

{ exp with exp_type = instance ty }

3265

| Tvar _ ->

3266

let exp = type_exp env sbody in

3267

let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in

3268

unify_exp env exp ty;

3269

exp

3270

| _ -> assert false

3271

in

3272

re { exp with exp_extra =

3273

(Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }

3274

| Pexp_newtype({txt=name}, sbody) ->

3275

let ty =

3276

if Typetexp.valid_tyvar_name name then

3277

newvar ~name ()

3278

else

3279

newvar ()

3280

in

3281

(* remember original level *)

3282

begin_def ();

3283

(* Create a fake abstract type declaration for name. *)

3284

let decl = {

3285

type_params = [];

3286

type_arity = 0;

3287

type_kind = Type_abstract;

3288

type_private = Public;

3289

type_manifest = None;

3290

type_variance = [];

3291

type_is_newtype = true;

3292

type_expansion_scope = Btype.lowest_level;

3293

type_loc = loc;

3294

type_attributes = [];

3295

type_immediate = Unknown;

3296

type_unboxed = unboxed_false_default_false;

3297

}

3298

in

3299

let scope = create_scope () in

3300

let (id, new_env) = Env.enter_type ~scope name decl env in

3301

3302

let body = type_exp new_env sbody in

3303

(* Replace every instance of this type constructor in the resulting

3304

type. *)

3305

let seen = Hashtbl.create 8 in

3306

let rec replace t =

3307

if Hashtbl.mem seen t.id then ()

3308

else begin

3309

Hashtbl.add seen t.id ();

3310

match t.desc with

3311

| Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty

3312

| _ -> Btype.iter_type_expr replace t

3313

end

3314

in

3315

let ety = Subst.type_expr Subst.identity body.exp_type in

3316

replace ety;

3317

(* back to original level *)

3318

end_def ();

3319

(* lower the levels of the result type *)

3320

(* unify_var env ty ety; *)

3321

3322

(* non-expansive if the body is non-expansive, so we don't introduce

3323

any new extra node in the typed AST. *)

3324

rue { body with exp_loc = loc; exp_type = ety;

3325

exp_extra =

3326

(Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }

3327

| Pexp_pack m ->

3328

let (p, nl) =

3329

match Ctype.expand_head env (instance ty_expected) with

3330

{desc = Tpackage (p, nl, _tl)} ->

3331

if !Clflags.principal &&

3332

(Ctype.expand_head env ty_expected).level < Btype.generic_level

3333

then

3334

Location.prerr_warning loc

3335

(Warnings.Not_principal "this module packing");

3336

(p, nl)

3337

| {desc = Tvar _} ->

3338

raise (Error (loc, env, Cannot_infer_signature))

3339

| _ ->

3340

raise (Error (loc, env, Not_a_packed_module ty_expected))

3341

in

3342

let (modl, tl') = !type_package env m p nl in

3343

rue {

3344

exp_desc = Texp_pack modl;

3345

exp_loc = loc; exp_extra = [];

3346

exp_type = newty (Tpackage (p, nl, tl'));

3347

exp_attributes = sexp.pexp_attributes;

3348

exp_env = env }

3349

| Pexp_open (od, e) ->

3350

let (od, _, newenv) = !type_open_decl env od in

3351

let exp = type_expect newenv e ty_expected_explained in

3352

rue {

3353

exp_desc = Texp_open (od, exp);

3354

exp_type = exp.exp_type;

3355

exp_loc = loc;

3356

exp_extra = [];

3357

exp_attributes = sexp.pexp_attributes;

3358

exp_env = env;

3359

}

3360

| Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->

3361

let rec loop spat_acc ty_acc sands =

3362

match sands with

3363

| [] -> spat_acc, ty_acc

3364

| { pbop_pat = spat; _} :: rest ->

3365

let ty = newvar () in

3366

let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in

3367

let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in

3368

let ty_acc = newty (Ttuple [ty_acc; ty]) in

3369

loop spat_acc ty_acc rest

3370

in

3371

if !Clflags.principal then begin_def ();

3372

let let_loc = slet.pbop_op.loc in

3373

let op_path, op_desc = type_binding_op_ident env slet.pbop_op in

3374

let op_type = instance op_desc.val_type in

3375

let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in

3376

let ty_func_result = newvar () in

3377

let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in

3378

let ty_result = newvar () in

3379

let ty_andops = newvar () in

3380

let ty_op =

3381

newty (Tarrow(Nolabel, ty_andops,

3382

newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))

3383

in

3384

begin try

3385

unify env op_type ty_op

3386

with Unify trace ->

3387

raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))

3388

end;

3389

if !Clflags.principal then begin

3390

end_def ();

3391

generalize_structure ty_andops;

3392

generalize_structure ty_params;

3393

generalize_structure ty_func_result;

3394

generalize_structure ty_result

3395

end;

3396

let exp, ands = type_andops env slet.pbop_exp sands ty_andops in

3397

let scase = Ast_helper.Exp.case spat_params sbody in

3398

let cases, partial =

3399

type_cases env ty_params ty_func_result true loc [scase]

3400

in

3401

let body =

3402

match cases with

3403

| [case] -> case

3404

| _ -> assert false

3405

in

3406

let param = name_cases "param" cases in

3407

let let_ =

3408

{ bop_op_name = slet.pbop_op;

3409

bop_op_path = op_path;

3410

bop_op_val = op_desc;

3411

bop_op_type = op_type;

3412

bop_exp = exp;

3413

bop_loc = slet.pbop_loc; }

3414

in

3415

let desc =

3416

Texp_letop{let_; ands; param; body; partial}

3417

in

3418

rue { exp_desc = desc;

3419

exp_loc = sexp.pexp_loc;

3420

exp_extra = [];

3421

exp_type = instance ty_result;

3422

exp_env = env;

3423

exp_attributes = sexp.pexp_attributes; }

3424

3425

| Pexp_extension ({ txt = ("ocaml.extension_constructor"

3426

|"extension_constructor"); _ },

3427

payload) ->

3428

begin match payload with

3429

| PStr [ { pstr_desc =

3430

Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)

3431

} ] ->

3432

let path =

3433

let cd =

3434

Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env

3435

in

3436

match cd.cstr_tag with

3437

| Cstr_extension (path, _) -> path

3438

| _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))

3439

in

3440

rue {

3441

exp_desc = Texp_extension_constructor (lid, path);

3442

exp_loc = loc; exp_extra = [];

3443

exp_type = instance Predef.type_extension_constructor;

3444

exp_attributes = sexp.pexp_attributes;

3445

exp_env = env }

3446

| _ ->

3447

raise (Error (loc, env, Invalid_extension_constructor_payload))

3448

end

3449

| Pexp_extension ext ->

3450

raise (Error_forward (Builtin_attributes.error_of_extension ext))

3451

3452

| Pexp_unreachable ->

3453

re { exp_desc = Texp_unreachable;

3454

exp_loc = loc; exp_extra = [];

3455

exp_type = instance ty_expected;

3456

exp_attributes = sexp.pexp_attributes;

3457

exp_env = env }

3458

3459

and type_ident env ?(recarg=Rejected) lid =

3460

let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in

3461

if !Clflags.annotations then begin

3462

let dloc = desc.Types.val_loc in

3463

let annot =

3464

if dloc.Location.loc_ghost then Annot.Iref_external

3465

else Annot.Iref_internal dloc

3466

in

3467

let name = Path.name ~paren:Oprint.parenthesized_ident path in

3468

Stypes.record (Stypes.An_ident (lid.loc, name, annot))

3469

end;

3470

let is_recarg =

3471

match (repr desc.val_type).desc with

3472

| Tconstr(p, _, _) -> Path.is_constructor_typath p

3473

| _ -> false

3474

in

3475

begin match is_recarg, recarg, (repr desc.val_type).desc with

3476

| _, Allowed, _

3477

| true, Required, _

3478

| false, Rejected, _ -> ()

3479

| true, Rejected, _

3480

| false, Required, (Tvar _ | Tconstr _) ->

3481

raise (Error (lid.loc, env, Inlined_record_escape))

3482

| false, Required, _ -> () (* will fail later *)

3483

end;

3484

path, desc

3485

3486

and type_binding_op_ident env s =

3487

let loc = s.loc in

3488

let lid = Location.mkloc (Longident.Lident s.txt) loc in

3489

let path, desc = type_ident env lid in

3490

let path =

3491

match desc.val_kind with

3492

| Val_ivar _ ->

3493

fatal_error "Illegal name for instance variable"

3494

| Val_self (_, _, cl_num, _) ->

3495

let path, _ =

3496

Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env

3497

in

3498

path

3499

| _ -> path

3500

in

3501

path, desc

3502

3503

and type_function ?in_function loc attrs env ty_expected_explained l caselist =

3504

let { ty = ty_expected; explanation } = ty_expected_explained in

3505

let (loc_fun, ty_fun) =

3506

match in_function with Some p -> p

3507

| None -> (loc, instance ty_expected)

3508

in

3509

let separate = !Clflags.principal || Env.has_local_constraints env in

3510

if separate then begin_def ();

3511

let (ty_arg, ty_res) =

3512

try filter_arrow env (instance ty_expected) l

3513

with Unify _ ->

3514

match expand_head env ty_expected with

3515

{desc = Tarrow _} as ty ->

3516

raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation)))

3517

| _ ->

3518

raise(Error(loc_fun, env,

3519

Too_many_arguments (in_function <> None,

3520

ty_fun,

3521

explanation)))

3522

in

3523

let ty_arg =

3524

if is_optional l then

3525

let tv = newvar() in

3526

begin

3527

try unify env ty_arg (type_option tv)

3528

with Unify _ -> assert false

3529

end;

3530

type_option tv

3531

else ty_arg

3532

in

3533

if separate then begin

3534

end_def ();

3535

generalize_structure ty_arg;

3536

generalize_structure ty_res

3537

end;

3538

let cases, partial =

3539

type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res

3540

true loc caselist in

3541

let not_function ty =

3542

let ls, tvar = list_labels env ty in

3543

ls = [] && not tvar

3544

in

3545

if is_optional l && not_function ty_res then

3546

Location.prerr_warning (List.hd cases).c_lhs.pat_loc

3547

Warnings.Unerasable_optional_argument;

3548

let param = name_cases "param" cases in

3549

re {

3550

exp_desc = Texp_function { arg_label = l; param; cases; partial; };

3551

exp_loc = loc; exp_extra = [];

3552

exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));

3553

exp_attributes = attrs;

3554

exp_env = env }

3555

3556

3557

and type_label_access env srecord lid =

3558

if !Clflags.principal then begin_def ();

3559

let record = type_exp ~recarg:Allowed env srecord in

3560

if !Clflags.principal then begin

3561

end_def ();

3562

generalize_structure record.exp_type

3563

end;

3564

let ty_exp = record.exp_type in

3565

let opath =

3566

try

3567

let (p0, p,_) = extract_concrete_record env ty_exp in

3568

Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)

3569

with Not_found -> None

3570

in

3571

let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in

3572

let label =

3573

wrap_disambiguate "This expression has" (mk_expected ty_exp)

3574

(Label.disambiguate () lid env opath) labels in

3575

(record, label, opath)

3576

3577

(* Typing format strings for printing or reading.

3578

These formats are used by functions in modules Printf, Format, and Scanf.

3579

(Handling of * modifiers contributed by Thorsten Ohl.) *)

3580

3581

and type_format loc str env =

3582

let loc = {loc with Location.loc_ghost = true} in

3583

try

3584

CamlinternalFormatBasics.(CamlinternalFormat.(

3585

let mk_exp_loc pexp_desc = {

3586

pexp_desc = pexp_desc;

3587

pexp_loc = loc;

3588

pexp_loc_stack = [];

3589

pexp_attributes = [];

3590

} and mk_lid_loc lid = {

3591

txt = lid;

3592

loc = loc;

3593

} in

3594

let mk_constr name args =

3595

let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in

3596

let arg = match args with

3597

| [] -> None

3598

| [ e ] -> Some e

3599

| _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in

3600

mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in

3601

let mk_cst cst = mk_exp_loc (Pexp_constant cst) in

3602

let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))

3603

and mk_string str = mk_cst (Pconst_string (str, None))

3604

and mk_char chr = mk_cst (Pconst_char chr) in

3605

let rec mk_formatting_lit fmting = match fmting with

3606

| Close_box ->

3607

mk_constr "Close_box" []

3608

| Close_tag ->

3609

mk_constr "Close_tag" []

3610

| Break (org, ns, ni) ->

3611

mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]

3612

| FFlush ->

3613

mk_constr "FFlush" []

3614

| Force_newline ->

3615

mk_constr "Force_newline" []

3616

| Flush_newline ->

3617

mk_constr "Flush_newline" []

3618

| Magic_size (org, sz) ->

3619

mk_constr "Magic_size" [ mk_string org; mk_int sz ]

3620

| Escaped_at ->

3621

mk_constr "Escaped_at" []

3622

| Escaped_percent ->

3623

mk_constr "Escaped_percent" []

3624

| Scan_indic c ->

3625

mk_constr "Scan_indic" [ mk_char c ]

3626

and mk_formatting_gen : type a b c d e f .

3627

(a, b, c, d, e, f) formatting_gen -> Parsetree.expression =

3628

fun fmting -> match fmting with

3629

| Open_tag (Format (fmt', str')) ->

3630

mk_constr "Open_tag" [ mk_format fmt' str' ]

3631

| Open_box (Format (fmt', str')) ->

3632

mk_constr "Open_box" [ mk_format fmt' str' ]

3633

and mk_format : type a b c d e f .

3634

(a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->

3635

Parsetree.expression = fun fmt str ->

3636

mk_constr "Format" [ mk_fmt fmt; mk_string str ]

3637

and mk_side side = match side with

3638

| Left -> mk_constr "Left" []

3639

| Right -> mk_constr "Right" []

3640

| Zeros -> mk_constr "Zeros" []

3641

and mk_iconv iconv = match iconv with

3642

| Int_d -> mk_constr "Int_d" [] | Int_pd -> mk_constr "Int_pd" []

3643

| Int_sd -> mk_constr "Int_sd" [] | Int_i -> mk_constr "Int_i" []

3644

| Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []

3645

| Int_x -> mk_constr "Int_x" [] | Int_Cx -> mk_constr "Int_Cx" []

3646

| Int_X -> mk_constr "Int_X" [] | Int_CX -> mk_constr "Int_CX" []

3647

| Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" []

3648

| Int_u -> mk_constr "Int_u" [] | Int_Cd -> mk_constr "Int_Cd" []

3649

| Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []

3650

and mk_fconv fconv =

3651

let flag = match fst fconv with

3652

| Float_flag_ -> mk_constr "Float_flag_" []

3653

| Float_flag_p -> mk_constr "Float_flag_p" []

3654

| Float_flag_s -> mk_constr "Float_flag_s" [] in

3655

let kind = match snd fconv with

3656

| Float_f -> mk_constr "Float_f" []

3657

| Float_e -> mk_constr "Float_e" []

3658

| Float_E -> mk_constr "Float_E" []

3659

| Float_g -> mk_constr "Float_g" []

3660

| Float_G -> mk_constr "Float_G" []

3661

| Float_h -> mk_constr "Float_h" []

3662

| Float_H -> mk_constr "Float_H" []

3663

| Float_F -> mk_constr "Float_F" []

3664

| Float_CF -> mk_constr "Float_CF" [] in

3665

mk_exp_loc (Pexp_tuple [flag; kind])

3666

and mk_counter cnt = match cnt with

3667

| Line_counter -> mk_constr "Line_counter" []

3668

| Char_counter -> mk_constr "Char_counter" []

3669

| Token_counter -> mk_constr "Token_counter" []

3670

and mk_int_opt n_opt = match n_opt with

3671

| None ->

3672

let lid_loc = mk_lid_loc (Longident.Lident "None") in

3673

mk_exp_loc (Pexp_construct (lid_loc, None))

3674

| Some n ->

3675

let lid_loc = mk_lid_loc (Longident.Lident "Some") in

3676

mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))

3677

and mk_fmtty : type a b c d e f g h i j k l .

3678

(a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression

3679

=

3680

fun fmtty -> match fmtty with

3681

| Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ]

3682

| String_ty rest -> mk_constr "String_ty" [ mk_fmtty rest ]

3683

| Int_ty rest -> mk_constr "Int_ty" [ mk_fmtty rest ]

3684

| Int32_ty rest -> mk_constr "Int32_ty" [ mk_fmtty rest ]

3685

| Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]

3686

| Int64_ty rest -> mk_constr "Int64_ty" [ mk_fmtty rest ]

3687

| Float_ty rest -> mk_constr "Float_ty" [ mk_fmtty rest ]

3688

| Bool_ty rest -> mk_constr "Bool_ty" [ mk_fmtty rest ]

3689

| Alpha_ty rest -> mk_constr "Alpha_ty" [ mk_fmtty rest ]

3690

| Theta_ty rest -> mk_constr "Theta_ty" [ mk_fmtty rest ]

3691

| Any_ty rest -> mk_constr "Any_ty" [ mk_fmtty rest ]

3692

| Reader_ty rest -> mk_constr "Reader_ty" [ mk_fmtty rest ]

3693

| Ignored_reader_ty rest ->

3694

mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]

3695

| Format_arg_ty (sub_fmtty, rest) ->

3696

mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]

3697

| Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->

3698

mk_constr "Format_subst_ty"

3699

[ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]

3700

| End_of_fmtty -> mk_constr "End_of_fmtty" []

3701

and mk_ignored : type a b c d e f .

3702

(a, b, c, d, e, f) ignored -> Parsetree.expression =

3703

fun ign -> match ign with

3704

| Ignored_char ->

3705

mk_constr "Ignored_char" []

3706

| Ignored_caml_char ->

3707

mk_constr "Ignored_caml_char" []

3708

| Ignored_string pad_opt ->

3709

mk_constr "Ignored_string" [ mk_int_opt pad_opt ]

3710

| Ignored_caml_string pad_opt ->

3711

mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]

3712

| Ignored_int (iconv, pad_opt) ->

3713

mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]

3714

| Ignored_int32 (iconv, pad_opt) ->

3715

mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]

3716

| Ignored_nativeint (iconv, pad_opt) ->

3717

mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]

3718

| Ignored_int64 (iconv, pad_opt) ->

3719

mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]

3720

| Ignored_float (pad_opt, prec_opt) ->

3721

mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]

3722

| Ignored_bool pad_opt ->

3723

mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]

3724

| Ignored_format_arg (pad_opt, fmtty) ->

3725

mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]

3726

| Ignored_format_subst (pad_opt, fmtty) ->

3727

mk_constr "Ignored_format_subst" [

3728

mk_int_opt pad_opt; mk_fmtty fmtty ]

3729

| Ignored_reader ->

3730

mk_constr "Ignored_reader" []

3731

| Ignored_scan_char_set (width_opt, char_set) ->

3732

mk_constr "Ignored_scan_char_set" [

3733

mk_int_opt width_opt; mk_string char_set ]

3734

| Ignored_scan_get_counter counter ->

3735

mk_constr "Ignored_scan_get_counter" [

3736

mk_counter counter

3737

]

3738

| Ignored_scan_next_char ->

3739

mk_constr "Ignored_scan_next_char" []

3740

and mk_padding : type x y . (x, y) padding -> Parsetree.expression =

3741

fun pad -> match pad with

3742

| No_padding -> mk_constr "No_padding" []

3743

| Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]

3744

| Arg_padding s -> mk_constr "Arg_padding" [ mk_side s ]

3745

and mk_precision : type x y . (x, y) precision -> Parsetree.expression =

3746

fun prec -> match prec with

3747

| No_precision -> mk_constr "No_precision" []

3748

| Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]

3749

| Arg_precision -> mk_constr "Arg_precision" []

3750

and mk_fmt : type a b c d e f .

3751

(a, b, c, d, e, f) fmt -> Parsetree.expression =

3752

fun fmt -> match fmt with

3753

| Char rest ->

3754

mk_constr "Char" [ mk_fmt rest ]

3755

| Caml_char rest ->

3756

mk_constr "Caml_char" [ mk_fmt rest ]

3757

| String (pad, rest) ->

3758

mk_constr "String" [ mk_padding pad; mk_fmt rest ]

3759

| Caml_string (pad, rest) ->

3760

mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]

3761

| Int (iconv, pad, prec, rest) ->

3762

mk_constr "Int" [

3763

mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]

3764

| Int32 (iconv, pad, prec, rest) ->

3765

mk_constr "Int32" [

3766

mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]

3767

| Nativeint (iconv, pad, prec, rest) ->

3768

mk_constr "Nativeint" [

3769

mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]

3770

| Int64 (iconv, pad, prec, rest) ->

3771

mk_constr "Int64" [

3772

mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]

3773

| Float (fconv, pad, prec, rest) ->

3774

mk_constr "Float" [

3775

mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]

3776

| Bool (pad, rest) ->

3777

mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]

3778

| Flush rest ->

3779

mk_constr "Flush" [ mk_fmt rest ]

3780

| String_literal (s, rest) ->

3781

mk_constr "String_literal" [ mk_string s; mk_fmt rest ]

3782

| Char_literal (c, rest) ->

3783

mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]

3784

| Format_arg (pad_opt, fmtty, rest) ->

3785

mk_constr "Format_arg" [

3786

mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]

3787

| Format_subst (pad_opt, fmtty, rest) ->

3788

mk_constr "Format_subst" [

3789

mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]

3790

| Alpha rest ->

3791

mk_constr "Alpha" [ mk_fmt rest ]

3792

| Theta rest ->

3793

mk_constr "Theta" [ mk_fmt rest ]

3794

| Formatting_lit (fmting, rest) ->

3795

mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]

3796

| Formatting_gen (fmting, rest) ->

3797

mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]

3798

| Reader rest ->

3799

mk_constr "Reader" [ mk_fmt rest ]

3800

| Scan_char_set (width_opt, char_set, rest) ->

3801

mk_constr "Scan_char_set" [

3802

mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]

3803

| Scan_get_counter (cnt, rest) ->

3804

mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]

3805

| Scan_next_char rest ->

3806

mk_constr "Scan_next_char" [ mk_fmt rest ]

3807

| Ignored_param (ign, rest) ->

3808

mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]

3809

| End_of_format ->

3810

mk_constr "End_of_format" []

3811

| Custom _ ->

3812

(* Custom formatters have no syntax so they will never appear

3813

in formats parsed from strings. *)

3814

assert false

3815

in

3816

let legacy_behavior = not !Clflags.strict_formats in

3817

let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in

3818

mk_constr "Format" [ mk_fmt fmt; mk_string str ]

3819

))

3820

with Failure msg ->

3821

raise (Error (loc, env, Invalid_format msg))

3822

3823

and type_label_exp create env loc ty_expected

3824

(lid, label, sarg) =

3825

(* Here also ty_expected may be at generic_level *)

3826

begin_def ();

3827

let separate = !Clflags.principal || Env.has_local_constraints env in

3828

if separate then (begin_def (); begin_def ());

3829

let (vars, ty_arg, ty_res) = instance_label true label in

3830

if separate then begin

3831

end_def ();

3832

(* Generalize label information *)

3833

generalize_structure ty_arg;

3834

generalize_structure ty_res

3835

end;

3836

begin try

3837

unify env (instance ty_res) (instance ty_expected)

3838

with Unify trace ->

3839

raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))

3840

end;

3841

(* Instantiate so that we can generalize internal nodes *)

3842

let ty_arg = instance ty_arg in

3843

if separate then begin

3844

end_def ();

3845

(* Generalize information merged from ty_expected *)

3846

generalize_structure ty_arg

3847

end;

3848

if label.lbl_private = Private then

3849

if create then

3850

raise (Error(loc, env, Private_type ty_expected))

3851

else

3852

raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));

3853

let arg =

3854

let snap = if vars = [] then None else Some (Btype.snapshot ()) in

3855

let arg = type_argument env sarg ty_arg (instance ty_arg) in

3856

end_def ();

3857

try

3858

check_univars env (vars <> []) "field value" arg label.lbl_arg vars;

3859

arg

3860

with exn when maybe_expansive arg -> try

3861

(* Try to retype without propagating ty_arg, cf PR#4862 *)

3862

Option.iter Btype.backtrack snap;

3863

begin_def ();

3864

let arg = type_exp env sarg in

3865

end_def ();

3866

lower_contravariant env arg.exp_type;

3867

unify_exp env arg ty_arg;

3868

check_univars env false "field value" arg label.lbl_arg vars;

3869

arg

3870

with Error (_, _, Less_general _) as e -> raise e

3871

| _ -> raise exn (* In case of failure return the first error *)

3872

in

3873

(lid, label, {arg with exp_type = instance arg.exp_type})

3874

3875

and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =

3876

(* ty_expected' may be generic *)

3877

let no_labels ty =

3878

let ls, tvar = list_labels env ty in

3879

not tvar && List.for_all ((=) Nolabel) ls

3880

in

3881

let rec is_inferred sexp =

3882

match sexp.pexp_desc with

3883

Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _

3884

| Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true

3885

| Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e

3886

| Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2

3887

| _ -> false

3888

in

3889

match expand_head env ty_expected' with

3890

{desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}

3891

when is_inferred sarg ->

3892

(* apply optional arguments when expected type is "" *)

3893

(* we must be very careful about not breaking the semantics *)

3894

if !Clflags.principal then begin_def ();

3895

let texp = type_exp env sarg in

3896

if !Clflags.principal then begin

3897

end_def ();

3898

generalize_structure texp.exp_type

3899

end;

3900

let rec make_args args ty_fun =

3901

match (expand_head env ty_fun).desc with

3902

| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->

3903

let ty = option_none env (instance ty_arg) sarg.pexp_loc in

3904

make_args ((l, Some ty) :: args) ty_fun

3905

| Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->

3906

List.rev args, ty_fun, no_labels ty_res'

3907

| Tvar _ -> List.rev args, ty_fun, false

3908

| _ -> [], texp.exp_type, false

3909

in

3910

let args, ty_fun', simple_res = make_args [] texp.exp_type in

3911

let warn = !Clflags.principal &&

3912

(lv <> generic_level || (repr ty_fun').level <> generic_level)

3913

and texp = {texp with exp_type = instance texp.exp_type}

3914

and ty_fun = instance ty_fun' in

3915

if not (simple_res || no_labels ty_res) then begin

3916

unify_exp env texp ty_expected;

3917

texp

3918

end else begin

3919

unify_exp env {texp with exp_type = ty_fun} ty_expected;

3920

if args = [] then texp else

3921

(* eta-expand to avoid side effects *)

3922

let var_pair name ty =

3923

let id = Ident.create_local name in

3924

let desc =

3925

{ val_type = ty; val_kind = Val_reg;

3926

val_attributes = [];

3927

Types.val_loc = Location.none}

3928

in

3929

let exp_env = Env.add_value id desc env in

3930

{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];

3931

pat_attributes = [];

3932

pat_loc = Location.none; pat_env = env},

3933

{exp_type = ty; exp_loc = Location.none; exp_env = exp_env;

3934

exp_extra = []; exp_attributes = [];

3935

exp_desc =

3936

Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}

3937

in

3938

let eta_pat, eta_var = var_pair "eta" ty_arg in

3939

let func texp =

3940

let e =

3941

{texp with exp_type = ty_res; exp_desc =

3942

Texp_apply

3943

(texp,

3944

args @ [Nolabel, Some eta_var])}

3945

in

3946

let cases = [case eta_pat e] in

3947

let param = name_cases "param" cases in

3948

{ texp with exp_type = ty_fun; exp_desc =

3949

Texp_function { arg_label = Nolabel; param; cases;

3950

partial = Total; } }

3951

in

3952

Location.prerr_warning texp.exp_loc

3953

(Warnings.Eliminated_optional_arguments

3954

(List.map (fun (l, _) -> Printtyp.string_of_label l) args));

3955

if warn then Location.prerr_warning texp.exp_loc

3956

(Warnings.Without_principality "eliminated optional argument");

3957

(* let-expand to have side effects *)

3958

let let_pat, let_var = var_pair "arg" texp.exp_type in

3959

re { texp with exp_type = ty_fun; exp_desc =

3960

Texp_let (Nonrecursive,

3961

[{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];

3962

vb_loc=Location.none;

3963

}],

3964

func let_var) }

3965

end

3966

| _ ->

3967

let texp = type_expect ?recarg env sarg

3968

(mk_expected ?explanation ty_expected') in

3969

unify_exp env texp ty_expected;

3970

texp

3971

3972

and type_application env funct sargs =

3973

(* funct.exp_type may be generic *)

3974

let result_type omitted ty_fun =

3975

List.fold_left

3976

(fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))

3977

ty_fun omitted

3978

in

3979

let has_label l ty_fun =

3980

let ls, tvar = list_labels env ty_fun in

3981

tvar || List.mem l ls

3982

in

3983

let ignored = ref [] in

3984

let rec type_unknown_args

3985

(args :

3986

(Asttypes.arg_label * (unit -> Typedtree.expression) option) list)

3987

omitted ty_fun = function

3988

[] ->

3989

(List.map

3990

(function l, None -> l, None

3991

| l, Some f -> l, Some (f ()))

3992

(List.rev args),

3993

instance (result_type omitted ty_fun))

3994

| (l1, sarg1) :: sargl ->

3995

let (ty1, ty2) =

3996

let ty_fun = expand_head env ty_fun in

3997

match ty_fun.desc with

3998

Tvar _ ->

3999

let t1 = newvar () and t2 = newvar () in

4000

let not_identity = function

4001

Texp_ident(_,_,{val_kind=Val_prim

4002

{Primitive.prim_name="%identity"}}) ->

4003

false

4004

| _ -> true

4005

in

4006

if ty_fun.level >= t1.level && not_identity funct.exp_desc then

4007

Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;

4008

unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));

4009

(t1, t2)

4010

| Tarrow (l,t1,t2,_) when l = l1

4011

|| !Clflags.classic && l1 = Nolabel && not (is_optional l) ->

4012

(t1, t2)

4013

| td ->

4014

let ty_fun =

4015

match td with Tarrow _ -> newty td | _ -> ty_fun in

4016

let ty_res = result_type (omitted @ !ignored) ty_fun in

4017

match ty_res.desc with

4018

Tarrow _ ->

4019

if (!Clflags.classic || not (has_label l1 ty_fun)) then

4020

raise (Error(sarg1.pexp_loc, env,

4021

Apply_wrong_label(l1, ty_res)))

4022

else

4023

raise (Error(funct.exp_loc, env, Incoherent_label_order))

4024

| _ ->

4025

raise(Error(funct.exp_loc, env, Apply_non_function

4026

(expand_head env funct.exp_type)))

4027

in

4028

let optional = is_optional l1 in

4029

let arg1 () =

4030

let arg1 = type_expect env sarg1 (mk_expected ty1) in

4031

if optional then

4032

unify_exp env arg1 (type_option(newvar()));

4033

arg1

4034

in

4035

type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl

4036

in

4037

let ignore_labels =

4038

!Clflags.classic ||

4039

begin

4040

let ls, tvar = list_labels env funct.exp_type in

4041

not tvar &&

4042

let labels = List.filter (fun l -> not (is_optional l)) ls in

4043

List.length labels = List.length sargs &&

4044

List.for_all (fun (l,_) -> l = Nolabel) sargs &&

4045

List.exists (fun l -> l <> Nolabel) labels &&

4046

(Location.prerr_warning

4047

funct.exp_loc

4048

(Warnings.Labels_omitted

4049

(List.map Printtyp.string_of_label

4050

(List.filter ((<>) Nolabel) labels)));

4051

true)

4052

end

4053

in

4054

let warned = ref false in

4055

let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =

4056

match expand_head env ty_fun, expand_head env ty_fun0 with

4057

{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',

4058

{desc=Tarrow (_, ty0, ty_fun0, _)}

4059

when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->

4060

let may_warn loc w =

4061

if not !warned && !Clflags.principal && lv <> generic_level

4062

then begin

4063

warned := true;

4064

Location.prerr_warning loc w

4065

end

4066

in

4067

let name = label_name l

4068

and optional = is_optional l in

4069

let sargs, more_sargs, arg =

4070

if ignore_labels && not (is_optional l) then begin

4071

(* In classic mode, omitted = [] *)

4072

match sargs, more_sargs with

4073

(l', sarg0) :: _, _ ->

4074

raise(Error(sarg0.pexp_loc, env,

4075

Apply_wrong_label(l', ty_old)))

4076

| _, (l', sarg0) :: more_sargs ->

4077

if l <> l' && l' <> Nolabel then

4078

raise(Error(sarg0.pexp_loc, env,

4079

Apply_wrong_label(l', ty_fun')))

4080

else

4081

([], more_sargs,

4082

Some (fun () -> type_argument env sarg0 ty ty0))

4083

| _ ->

4084

assert false

4085

end else try

4086

let (l', sarg0, sargs, more_sargs) =

4087

try

4088

let (l', sarg0, sargs1, sargs2) = extract_label name sargs in

4089

if sargs1 <> [] then

4090

may_warn sarg0.pexp_loc

4091

(Warnings.Not_principal "commuting this argument");

4092

(l', sarg0, sargs1 @ sargs2, more_sargs)

4093

with Not_found ->

4094

let (l', sarg0, sargs1, sargs2) =

4095

extract_label name more_sargs in

4096

if sargs1 <> [] || sargs <> [] then

4097

may_warn sarg0.pexp_loc

4098

(Warnings.Not_principal "commuting this argument");

4099

(l', sarg0, sargs @ sargs1, sargs2)

4100

in

4101

if not optional && is_optional l' then

4102

Location.prerr_warning sarg0.pexp_loc

4103

(Warnings.Nonoptional_label (Printtyp.string_of_label l));

4104

sargs, more_sargs,

4105

if not optional || is_optional l' then

4106

Some (fun () -> type_argument env sarg0 ty ty0)

4107

else begin

4108

may_warn sarg0.pexp_loc

4109

(Warnings.Not_principal "using an optional argument here");

4110

Some (fun () -> option_some env (type_argument env sarg0

4111

(extract_option_type env ty)

4112

(extract_option_type env ty0)))

4113

end

4114

with Not_found ->

4115

sargs, more_sargs,

4116

if optional &&

4117

(List.mem_assoc Nolabel sargs

4118

|| List.mem_assoc Nolabel more_sargs)

4119

then begin

4120

may_warn funct.exp_loc

4121

(Warnings.Without_principality "eliminated optional argument");

4122

ignored := (l,ty,lv) :: !ignored;

4123

Some (fun () -> option_none env (instance ty) Location.none)

4124

end else begin

4125

may_warn funct.exp_loc

4126

(Warnings.Without_principality "commuted an argument");

4127

None

4128

end

4129

in

4130

let omitted =

4131

if arg = None then (l,ty,lv) :: omitted else omitted in

4132

let ty_old = if sargs = [] then ty_fun else ty_old in

4133

type_args ((l,arg)::args) omitted ty_fun ty_fun0

4134

ty_old sargs more_sargs

4135

| _ ->

4136

match sargs with

4137

(l, sarg0) :: _ when ignore_labels ->

4138

raise(Error(sarg0.pexp_loc, env,

4139

Apply_wrong_label(l, ty_old)))

4140

| _ ->

4141

type_unknown_args args omitted ty_fun0

4142

(sargs @ more_sargs)

4143

in

4144

let is_ignore funct =

4145

match funct.exp_desc with

4146

Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) ->

4147

(try ignore (filter_arrow env (instance funct.exp_type) Nolabel);

4148

true

4149

with Unify _ -> false)

4150

| _ -> false

4151

in

4152

match sargs with

4153

(* Special case for ignore: avoid discarding warning *)

4154

[Nolabel, sarg] when is_ignore funct ->

4155

let ty_arg, ty_res =

4156

filter_arrow env (instance funct.exp_type) Nolabel

4157

in

4158

let exp = type_expect env sarg (mk_expected ty_arg) in

4159

check_partial_application false exp;

4160

([Nolabel, Some exp], ty_res)

4161

| _ ->

4162

let ty = funct.exp_type in

4163

if ignore_labels then

4164

type_args [] [] ty (instance ty) ty [] sargs

4165

else

4166

type_args [] [] ty (instance ty) ty sargs []

4167

4168

and type_construct env loc lid sarg ty_expected_explained attrs =

4169

let { ty = ty_expected; explanation } = ty_expected_explained in

4170

let opath =

4171

try

4172

let (p0, p,_) = extract_concrete_variant env ty_expected in

4173

let principal =

4174

(repr ty_expected).level = generic_level || not !Clflags.principal

4175

in

4176

Some(p0, p, principal)

4177

with Not_found -> None

4178

in

4179

let constrs =

4180

Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env

4181

in

4182

let constr =

4183

wrap_disambiguate "This variant expression is expected to have"

4184

ty_expected_explained

4185

(Constructor.disambiguate Env.Positive lid env opath) constrs

4186

in

4187

let sargs =

4188

match sarg with

4189

None -> []

4190

| Some {pexp_desc = Pexp_tuple sel} when

4191

constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs

4192

-> sel

4193

| Some se -> [se] in

4194

if List.length sargs <> constr.cstr_arity then

4195

raise(Error(loc, env, Constructor_arity_mismatch

4196

(lid.txt, constr.cstr_arity, List.length sargs)));

4197

let separate = !Clflags.principal || Env.has_local_constraints env in

4198

if separate then (begin_def (); begin_def ());

4199

let (ty_args, ty_res) = instance_constructor constr in

4200

let texp =

4201

re {

4202

exp_desc = Texp_construct(lid, constr, []);

4203

exp_loc = loc; exp_extra = [];

4204

exp_type = ty_res;

4205

exp_attributes = attrs;

4206

exp_env = env } in

4207

if separate then begin

4208

end_def ();

4209

generalize_structure ty_res;

4210

with_explanation explanation (fun () ->

4211

unify_exp env {texp with exp_type = instance ty_res}

4212

(instance ty_expected));

4213

end_def ();

4214

List.iter generalize_structure ty_args;

4215

generalize_structure ty_res;

4216

end;

4217

let ty_args0, ty_res =

4218

match instance_list (ty_res :: ty_args) with

4219

t :: tl -> tl, t

4220

| _ -> assert false

4221

in

4222

let texp = {texp with exp_type = ty_res} in

4223

if not separate then unify_exp env texp (instance ty_expected);

4224

let recarg =

4225

match constr.cstr_inlined with

4226

| None -> Rejected

4227

| Some _ ->

4228

begin match sargs with

4229

| [{pexp_desc =

4230

Pexp_ident _ |

4231

Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->

4232

Required

4233

| _ ->

4234

raise (Error(loc, env, Inlined_record_expected))

4235

end

4236

in

4237

let args =

4238

List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs

4239

(List.combine ty_args ty_args0) in

4240

if constr.cstr_private = Private then

4241

begin match constr.cstr_tag with

4242

| Cstr_extension _ ->

4243

raise(Error(loc, env, Private_constructor (constr, ty_res)))

4244

| Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->

4245

raise (Error(loc, env, Private_type ty_res));

4246

end;

4247

(* NOTE: shouldn't we call "re" on this final expression? -- AF *)

4248

{ texp with

4249

exp_desc = Texp_construct(lid, constr, args) }

4250

4251

(* Typing of statements (expressions whose values are discarded) *)

4252

4253

and type_statement ?explanation env sexp =

4254

begin_def();

4255

let exp = type_exp env sexp in

4256

end_def();

4257

let ty = expand_head env exp.exp_type and tv = newvar() in

4258

if is_Tvar ty && ty.level > tv.level then

4259

Location.prerr_warning

4260

(final_subexpression exp).exp_loc

4261

Warnings.Nonreturning_statement;

4262

if !Clflags.strict_sequence then

4263

let expected_ty = instance Predef.type_unit in

4264

with_explanation explanation (fun () ->

4265

unify_exp env exp expected_ty);

4266

exp

4267

else begin

4268

check_partial_application true exp;

4269

unify_var env tv ty;

4270

exp

4271

end

4272

4273

(* Typing of match cases *)

4274

and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag

4275

loc caselist =

4276

(* ty_arg is _fully_ generalized *)

4277

let patterns = List.map (fun {pc_lhs=p} -> p) caselist in

4278

let contains_polyvars = List.exists contains_polymorphic_variant patterns in

4279

let erase_either = contains_polyvars && contains_variant_either ty_arg in

4280

let may_contain_gadts = List.exists may_contain_gadts patterns in

4281

let ty_arg =

4282

if (may_contain_gadts || erase_either) && not !Clflags.principal

4283

then correct_levels ty_arg else ty_arg

4284

in

4285

let rec is_var spat =

4286

match spat.ppat_desc with

4287

Ppat_any | Ppat_var _ -> true

4288

| Ppat_alias (spat, _) -> is_var spat

4289

| _ -> false in

4290

let needs_exhaust_check =

4291

match caselist with

4292

[{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true

4293

| [{pc_lhs}] when is_var pc_lhs -> false

4294

| _ -> true

4295

in

4296

let outer_level = get_current_level () in

4297

let lev =

4298

if may_contain_gadts then begin_def ();

4299

get_current_level ()

4300

in

4301

let take_partial_instance =

4302

if !Clflags.principal || erase_either

4303

then Some false else None

4304

in

4305

begin_def (); (* propagation of the argument *)

4306

let pattern_force = ref [] in

4307

(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())

4308

Printtyp.raw_type_expr ty_arg; *)

4309

let half_typed_cases =

4310

List.map

4311

(fun ({pc_lhs; pc_guard; pc_rhs} as case) ->

4312

let loc =

4313

let open Location in

4314

match pc_guard with

4315

| None -> pc_rhs.pexp_loc

4316

| Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}

4317

in

4318

if !Clflags.principal then begin_def (); (* propagation of pattern *)

4319

let scope = Some (Annot.Idef loc) in

4320

begin_def ();

4321

let ty_arg = instance ?partial:take_partial_instance ty_arg in

4322

end_def ();

4323

generalize_structure ty_arg;

4324

let (pat, ext_env, force, pvs, unpacks) =

4325

type_pattern ?exception_allowed ~lev env pc_lhs scope ty_arg

4326

in

4327

pattern_force := force @ !pattern_force;

4328

let pat =

4329

if !Clflags.principal then begin

4330

end_def ();

4331

iter_pattern_variables_type generalize_structure pvs;

4332

{ pat with pat_type = instance pat.pat_type }

4333

end else pat

4334

in

4335

(* Ensure that no ambivalent pattern type escapes its branch *)

4336

check_scope_escape pat.pat_loc env outer_level ty_arg;

4337

{ typed_pat = pat;

4338

pat_type_for_unif = ty_arg;

4339

untyped_case = case;

4340

branch_env = ext_env;

4341

pat_vars = pvs;

4342

unpacks;

4343

contains_gadt = contains_gadt pat; }

4344

)

4345

caselist in

4346

let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in

4347

let does_contain_gadt =

4348

List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases

4349

in

4350

let ty_res, do_copy_types =

4351

if does_contain_gadt && not !Clflags.principal then

4352

correct_levels ty_res, Env.make_copy_of_types env

4353

else ty_res, (fun env -> env)

4354

in

4355

(* Unify all cases (delayed to keep it order-free) *)

4356

let ty_arg' = newvar () in

4357

let unify_pats ty =

4358

List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->

4359

unify_pat_types pat.pat_loc (ref env) pat_ty ty

4360

) half_typed_cases

4361

in

4362

unify_pats ty_arg';

4363

(* Check for polymorphic variants to close *)

4364

if List.exists has_variants patl then begin

4365

Parmatch.pressure_variants env patl;

4366

List.iter (iter_pattern finalize_variant) patl

4367

end;

4368

(* `Contaminating' unifications start here *)

4369

List.iter (fun f -> f()) !pattern_force;

4370

(* Post-processing and generalization *)

4371

if take_partial_instance <> None then unify_pats (instance ty_arg);

4372

List.iter (fun { pat_vars; _ } ->

4373

iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars

4374

) half_typed_cases;

4375

end_def ();

4376

generalize ty_arg';

4377

List.iter (fun { pat_vars; _ } ->

4378

iter_pattern_variables_type generalize pat_vars

4379

) half_typed_cases;

4380

(* type bodies *)

4381

let in_function = if List.length caselist = 1 then in_function else None in

4382

let cases =

4383

List.map

4384

(fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;

4385

untyped_case = {pc_lhs = _; pc_guard; pc_rhs};

4386

contains_gadt; _ } ->

4387

let ext_env =

4388

if contains_gadt then

4389

do_copy_types ext_env

4390

else

4391

ext_env

4392

in

4393

let ext_env =

4394

add_pattern_variables ext_env pvs

4395

~check:(fun s -> Warnings.Unused_var_strict s)

4396

~check_as:(fun s -> Warnings.Unused_var s)

4397

in

4398

let sexp = wrap_unpacks pc_rhs unpacks in

4399

let ty_res' =

4400

if !Clflags.principal then begin

4401

begin_def ();

4402

let ty = instance ~partial:true ty_res in

4403

end_def ();

4404

generalize_structure ty; ty

4405

end

4406

else if contains_gadt then

4407

(* Even though we've already done that, apparently we need to do it

4408

again.

4409

stdlib/camlinternalFormat.ml:2288 is an example of use of this

4410

call to [correct_levels]... *)

4411

correct_levels ty_res

4412

else ty_res in

4413

(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())

4414

Printtyp.raw_type_expr ty_res'; *)

4415

let guard =

4416

match pc_guard with

4417

| None -> None

4418

| Some scond ->

4419

Some

4420

(type_expect ext_env (wrap_unpacks scond unpacks)

4421

(mk_expected ~explanation:When_guard Predef.type_bool))

4422

in

4423

let exp =

4424

type_expect ?in_function ext_env sexp (mk_expected ty_res') in

4425

{

4426

c_lhs = pat;

4427

c_guard = guard;

4428

c_rhs = {exp with exp_type = instance ty_res'}

4429

}

4430

)

4431

half_typed_cases

4432

in

4433

if !Clflags.principal || does_contain_gadt then begin

4434

let ty_res' = instance ty_res in

4435

List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases

4436

end;

4437

let do_init = may_contain_gadts || needs_exhaust_check in

4438

let ty_arg_check =

4439

if do_init then

4440

(* Hack: use for_saving to copy variables too *)

4441

Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'

4442

else ty_arg'

4443

in

4444

let val_cases, exn_cases = split_cases env cases in

4445

if val_cases = [] && exn_cases <> [] then

4446

raise (Error (loc, env, No_value_clauses));

4447

let partial =

4448

if partial_flag then

4449

check_partial ~lev env ty_arg_check loc val_cases

4450

else

4451

Partial

4452

in

4453

let unused_check delayed =

4454

List.iter (fun { typed_pat; branch_env; _ } ->

4455

check_absent_variant branch_env typed_pat

4456

) half_typed_cases;

4457

if delayed then (begin_def (); init_def lev);

4458

check_unused ~lev env ty_arg_check val_cases ;

4459

check_unused ~lev env Predef.type_exn exn_cases ;

4460

if delayed then end_def ();

4461

Parmatch.check_ambiguous_bindings val_cases ;

4462

Parmatch.check_ambiguous_bindings exn_cases

4463

in

4464

if contains_polyvars then

4465

add_delayed_check (fun () -> unused_check true)

4466

else

4467

(* Check for unused cases, do not delay because of gadts *)

4468

unused_check false;

4469

if may_contain_gadts then begin

4470

end_def ();

4471

(* Ensure that existential types do not escape *)

4472

unify_exp_types loc env (instance ty_res) (newvar ()) ;

4473

end;

4474

cases, partial

4475

4476

(* Typing of let bindings *)

4477

4478

and type_let

4479

?(check = fun s -> Warnings.Unused_var s)

4480

?(check_strict = fun s -> Warnings.Unused_var_strict s)

4481

existential_context

4482

env rec_flag spat_sexp_list scope allow =

4483

let open Ast_helper in

4484

begin_def();

4485

if !Clflags.principal then begin_def ();

4486

4487

let is_fake_let =

4488

match spat_sexp_list with

4489

| [{pvb_expr={pexp_desc=Pexp_match(

4490

{pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->

4491

true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)

4492

| _ ->

4493

false

4494

in

4495

let check = if is_fake_let then check_strict else check in

4496

4497

let spatl =

4498

List.map

4499

(fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->

4500

attrs,

4501

match spat.ppat_desc, sexp.pexp_desc with

4502

(Ppat_any | Ppat_constraint _), _ -> spat

4503

| _, Pexp_coerce (_, _, sty)

4504

| _, Pexp_constraint (_, sty) when !Clflags.principal ->

4505

(* propagate type annotation to pattern,

4506

to allow it to be generalized in -principal mode *)

4507

Pat.constraint_

4508

~loc:{spat.ppat_loc with Location.loc_ghost=true}

4509

spat

4510

sty

4511

| _ -> spat)

4512

spat_sexp_list in

4513

let nvs = List.map (fun _ -> newvar ()) spatl in

4514

let (pat_list, new_env, force, pvs, unpacks) =

4515

type_pattern_list existential_context env spatl scope nvs allow in

4516

let attrs_list = List.map fst spatl in

4517

let is_recursive = (rec_flag = Recursive) in

4518

(* If recursive, first unify with an approximation of the expression *)

4519

if is_recursive then

4520

List.iter2

4521

(fun pat binding ->

4522

let pat =

4523

match pat.pat_type.desc with

4524

| Tpoly (ty, tl) ->

4525

{pat with pat_type =

4526

snd (instance_poly ~keep_names:true false tl ty)}

4527

| _ -> pat

4528

in unify_pat (ref env) pat (type_approx env binding.pvb_expr))

4529

pat_list spat_sexp_list;

4530

(* Polymorphic variant processing *)

4531

List.iter

4532

(fun pat ->

4533

if has_variants pat then begin

4534

Parmatch.pressure_variants env [pat];

4535

iter_pattern finalize_variant pat

4536

end)

4537

pat_list;

4538

(* Generalize the structure *)

4539

let pat_list =

4540

if !Clflags.principal then begin

4541

end_def ();

4542

iter_pattern_variables_type generalize_structure pvs;

4543

List.map (fun pat ->

4544

generalize_structure pat.pat_type;

4545

{pat with pat_type = instance pat.pat_type}

4546

) pat_list

4547

end else

4548

pat_list

4549

in

4550

(* Only