Merge branch 'jalon3' of gaufre.informatique.univ-paris-diderot.fr:Anri/compilation-m1-2023 into jalon3

This commit is contained in:
Nicolas PENELOUX 2023-12-04 18:40:36 +01:00
commit a66f9f57fd

View file

@ -2,6 +2,8 @@
open HopixAST open HopixAST
let get_aty (HopixTypes.Scheme (_, aty_value)) : HopixTypes.aty = aty_value
(** Error messages *) (** Error messages *)
let invalid_instantiation pos given expected = let invalid_instantiation pos given expected =
@ -43,11 +45,9 @@ let check_type_scheme
fun env pos (ForallTy (ts, ty)) -> fun env pos (ForallTy (ts, ty)) ->
let ts = List.map Position.value ts in let ts = List.map Position.value ts in
let env = HopixTypes.bind_type_variables pos env ts in let env = HopixTypes.bind_type_variables pos env ts in
(HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env) HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env
;; ;;
let rec check_pattern let rec check_pattern
: HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixTypes.aty : HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixTypes.aty
-> HopixTypes.typing_environment -> HopixTypes.typing_environment
@ -111,17 +111,17 @@ and synth_apply
: HopixTypes.typing_environment -> expression Position.located : HopixTypes.typing_environment -> expression Position.located
-> expression Position.located -> HopixTypes.aty -> expression Position.located -> HopixTypes.aty
= =
fun tenv f x -> (*failwith "Students! This is your job! (synth_apply)"*) fun tenv f x ->
(*failwith "Students! This is your job! (synth_apply)"*)
let f_type = synth_expression tenv f in let f_type = synth_expression tenv f in
match f_type with match f_type with
| HopixTypes.ATyArrow (gauche,droit) -> (* a' -> b' *) | HopixTypes.ATyArrow (gauche, droit) ->
( (* a' -> b' *)
let x_type = synth_expression tenv x in let x_type = synth_expression tenv x in
check_equal_types x.position gauche x_type; droit check_equal_types x.position gauche x_type;
) droit
| _ -> failwith "" | _ -> failwith ""
and synth_record and synth_record
: HopixTypes.typing_environment : HopixTypes.typing_environment
-> (label Position.located * expression Position.located) list -> (label Position.located * expression Position.located) list
@ -215,7 +215,6 @@ and synth_for
= =
fun tenv id estart eend expr -> failwith "Students! This is your job! (synth_for)" fun tenv id estart eend expr -> failwith "Students! This is your job! (synth_for)"
and check_expression and check_expression
: HopixTypes.typing_environment -> HopixAST.expression Position.located : HopixTypes.typing_environment -> HopixAST.expression Position.located
-> HopixTypes.aty -> unit -> HopixTypes.aty -> unit
@ -223,7 +222,9 @@ and check_expression
fun env (Position.{ value = e; position = pos } as exp) expected -> fun env (Position.{ value = e; position = pos } as exp) expected ->
match e with match e with
| Fun df -> failwith "Students! This is your job! Fun check" | Fun df -> failwith "Students! This is your job! Fun check"
| _ -> failwith "Students! This is your job! check_expression wildcard" | _ ->
let given = synth_expression env exp in
check_equal_types pos ~expected ~given
and check_value_definition and check_value_definition
: HopixTypes.typing_environment -> HopixAST.value_definition : HopixTypes.typing_environment -> HopixAST.value_definition
@ -232,10 +233,11 @@ and check_value_definition
fun env -> function fun env -> function
| SimpleValue (id, ty, ex) -> | SimpleValue (id, ty, ex) ->
(match ty with (match ty with
| None -> failwith "Type missing." | None -> failwith "A type is missing."
| Some ty' -> | Some ty' ->
(*failwith "Students! This is your job! (check_value_definition | SimpleValue)"*) (*failwith "Students! This is your job! (check_value_definition | SimpleValue)"*)
let tys,_ = Position.located_pos (check_type_scheme env) ty' in let tys, tenv = Position.located_pos (check_type_scheme env) ty' in
check_expression tenv ex (get_aty tys);
HopixTypes.bind_value (Position.value id) tys env) HopixTypes.bind_value (Position.value id) tys env)
| RecFunctions _ -> | RecFunctions _ ->
(* Je crois que c'est galère et donc c'est pas grave si on arrive pas (* Je crois que c'est galère et donc c'est pas grave si on arrive pas