Commit 19d51a76 authored by Raphaël Cauderlier's avatar Raphaël Cauderlier
Browse files

Missing from last commit

parent ea21e1af
......@@ -7,6 +7,9 @@ type tterm =
| Tpar of tterm
| Tapp of tterm * tterm * sty * sty
| Tabst of id * sty * tterm * sty
| Ttrue of sty
| Tfalse of sty
| Tif of tterm * tterm * tterm * sty
| Tobj of (label * tmeth) list * sty
| Tsel of tterm * label * sty
| Tupd of tterm * label * tmeth * sty
......@@ -23,17 +26,19 @@ type tline =
type typed_tree = tline list
exception Sty_assoc_arrow
exception Sty_assoc
let rec sty_assoc l = function
| Stcid (_, b) -> sty_assoc l b
| Stlist ll -> List.assoc l ll
| Starr _ -> raise Sty_assoc_arrow
| Starr _
| Stbool _ -> raise Sty_assoc
exception Application_of_non_functionnal_value
exception Application_of_non_functionnal_value of sty
let rec sty_decompose_arrow = function
| Stcid (_, b) -> sty_decompose_arrow b
| Stlist _ -> raise Application_of_non_functionnal_value
| Stbool _
| Stlist _ as ty -> raise (Application_of_non_functionnal_value ty)
| Starr (t1, t2) -> (t1, t2)
let rec subtype (a : sty) : sty -> bool = function
......@@ -41,6 +46,9 @@ let rec subtype (a : sty) : sty -> bool = function
| Starr (b1, b2) -> (match a with
| Starr (a1, a2) -> eq a1 b1 && eq a2 b2
| _ -> false)
| Stbool b -> (match a with
| Stbool a -> eq a b
| _ -> false)
| Stlist [] -> true
| Stlist ((l, bl) :: b) ->
try
......@@ -49,15 +57,18 @@ let rec subtype (a : sty) : sty -> bool = function
and eq a b = subtype a b && subtype b a
let rec infer : tterm -> sty = function
| Tvar (_, ty) -> ty
| Tconst (_, ty, _) -> ty
| Tpar t -> infer t
| Tapp (_, _, _, ty) -> ty
| Tabst (_, ty, _, rty) -> Starr (ty, rty)
| Tobj (_, ty) -> ty
| Tsel (_, _, ty) -> ty
| Tupd (_, _, _, ty) -> ty
| Tvar (_, ty)
| Tconst (_, ty, _)
| Tapp (_, _, _, ty)
| Tif (_, _, _, ty)
| Tobj (_, ty)
| Tsel (_, _, ty)
| Tupd (_, _, _, ty)
| Tcast (_, _, ty) -> ty
| Tabst (_, ty, _, rty) -> Starr (ty, rty)
| Ttrue ty
| Tfalse ty -> Stbool ty
and infer_meth (Tmeth (_, _, _, ty)) = ty
exception Subtype_checking_error of sty * sty
......@@ -142,6 +153,8 @@ and type_check_object env ty obj =
| Stcid (_, b) -> type_check_object env b obj
| Starr _ ->
Format.eprintf "Trying to type an object with an arrow type@."; exit 1
| Stbool _ ->
Format.eprintf "Trying to type an object with a boolean type@."; exit 1
| Stlist [] -> (
match obj with
| [] -> []
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment