Paris7/compilation
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Activity

correction d'un bug

Browse source
This commit is contained in:
Nicolas PENELOUX 2023-12-06 18:05:43 +01:00
parent e0bb403e11
commit 8b3a34ba2d
1 changed files with 11 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
flap/src/hopix/hopixTypechecker.ml
View file

@ -272,31 +272,30 @@ and pattern_record
try HopixTypes.lookup_type_constructor_of_label label.position label.value tenv with try HopixTypes.lookup_type_constructor_of_label label.position label.value tenv with
| HopixTypes.Unbound (pos, Label (LId i)) -> | HopixTypes.Unbound (pos, Label (LId i)) ->
HopixTypes.type_error pos (Printf.sprintf "There is no type definition for label `%s'." label_name ) HopixTypes.type_error pos (Printf.sprintf "There is no type definition for label `%s'." label_name )
(* Printf.sprintf "erreur message ici"*)
in in
let tlist' = let tlist' =
match tlist with match tlist with
| Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist | Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist
| None -> HopixTypes.type_error label.position "No types found." | None -> HopixTypes.type_error label.position "No types found."
in in
List.iter let tenv =
(fun (Position.{ position = label_pos; value = label_val }, pat) -> List.fold_left (
fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
let label_scheme = let label_scheme =
try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
| HopixTypes.Unbound (pos, Label (LId i)) -> | HopixTypes.Unbound (pos, Label (LId i)) ->
HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i) HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
in in
let arrow = let instance_type_scheme =
try HopixTypes.instantiate_type_scheme label_scheme tlist' with try HopixTypes.instantiate_type_scheme label_scheme tlist' with
| HopixTypes.InvalidInstantiation { expected; given } -> | HopixTypes.InvalidInstantiation { expected; given } ->
invalid_instantiation (Position.position pat) expected given invalid_instantiation (Position.position pat) expected given
in in
let expected,_ = HopixTypes.destruct_function_type label_pos arrow in let _,expected = HopixTypes.destruct_function_type label_pos instance_type_scheme in
let given,_ = synth_pattern tenv pat in let (given,tenv) = synth_pattern tenv pat in
check_equal_types label_pos ~expected ~given) check_equal_types label_pos ~expected ~given; tenv
plist; ) tenv plist;
in
ATyCon(type_cons, tlist'),tenv ATyCon(type_cons, tlist'),tenv