Merge branch 'jalon3' of gaufre.informatique.univ-paris-diderot.fr:Anri/compilation-m1-2023 into jalon3
This commit is contained in:
commit
a66f9f57fd
1 changed files with 19 additions and 17 deletions
|
@ -2,6 +2,8 @@
|
|||
|
||||
open HopixAST
|
||||
|
||||
let get_aty (HopixTypes.Scheme (_, aty_value)) : HopixTypes.aty = aty_value
|
||||
|
||||
(** Error messages *)
|
||||
|
||||
let invalid_instantiation pos given expected =
|
||||
|
@ -41,13 +43,11 @@ let check_type_scheme
|
|||
-> HopixTypes.aty_scheme * HopixTypes.typing_environment
|
||||
=
|
||||
fun env pos (ForallTy (ts, ty)) ->
|
||||
let ts = List.map Position.value ts in
|
||||
let env = HopixTypes.bind_type_variables pos env ts in
|
||||
(HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env)
|
||||
let ts = List.map Position.value ts in
|
||||
let env = HopixTypes.bind_type_variables pos env ts in
|
||||
HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let rec check_pattern
|
||||
: HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixTypes.aty
|
||||
-> HopixTypes.typing_environment
|
||||
|
@ -81,7 +81,7 @@ let rec synth_expression
|
|||
| While (ecase, expr) -> synth_while env ecase expr
|
||||
| For (id, ecase, expr1, expr2) -> synth_for env id ecase expr1 expr2
|
||||
|
||||
and synth_literal : HopixAST.literal -> HopixTypes.aty =
|
||||
and synth_literal : HopixAST.literal -> HopixTypes.aty =
|
||||
fun l ->
|
||||
match l with
|
||||
| LInt _ -> HopixTypes.hint
|
||||
|
@ -111,16 +111,16 @@ and synth_apply
|
|||
: HopixTypes.typing_environment -> expression Position.located
|
||||
-> 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
|
||||
match f_type with
|
||||
| HopixTypes.ATyArrow (gauche,droit) -> (* a' -> b' *)
|
||||
(
|
||||
match f_type with
|
||||
| HopixTypes.ATyArrow (gauche, droit) ->
|
||||
(* a' -> b' *)
|
||||
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 ""
|
||||
|
||||
|
||||
and synth_record
|
||||
: HopixTypes.typing_environment
|
||||
|
@ -215,7 +215,6 @@ and synth_for
|
|||
=
|
||||
fun tenv id estart eend expr -> failwith "Students! This is your job! (synth_for)"
|
||||
|
||||
|
||||
and check_expression
|
||||
: HopixTypes.typing_environment -> HopixAST.expression Position.located
|
||||
-> HopixTypes.aty -> unit
|
||||
|
@ -223,7 +222,9 @@ and check_expression
|
|||
fun env (Position.{ value = e; position = pos } as exp) expected ->
|
||||
match e with
|
||||
| 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
|
||||
: HopixTypes.typing_environment -> HopixAST.value_definition
|
||||
|
@ -232,10 +233,11 @@ and check_value_definition
|
|||
fun env -> function
|
||||
| SimpleValue (id, ty, ex) ->
|
||||
(match ty with
|
||||
| None -> failwith "Type missing."
|
||||
| None -> failwith "A type is missing."
|
||||
| Some ty' ->
|
||||
(*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)
|
||||
| RecFunctions _ ->
|
||||
(* Je crois que c'est galère et donc c'est pas grave si on arrive pas
|
||||
|
|
Reference in a new issue