let rec type_data_types dt_lst env =
match dt_lst with
Ast.SynIntType::rest -> TyInt::(type_data_types rest env)
| Ast.SynFloatType::rest -> TyFloat::(type_data_types rest env)
| Ast.SynStringType::rest -> TyString::(type_data_types rest env)
| Ast.SynBoolType::rest -> TyBool::(type_data_types rest env)
| Ast.SynVoidType::rest -> TyVoid::(type_data_types rest env)
| (Ast.SynEnumOrStructType (s,field_types))::rest ->
if isdef_struct s env then
let _ = field_types := get_struct_data_type_list s env in
(TyStruct s)::(type_data_types rest env)
else if isdef_enum s env then
(TyEnum s)::(type_data_types rest env)
else if isdef_templated s env then
(TyTemplate s)::(type_data_types rest env)
else raise_type_error ["Invalid data type: ";s;" expected enum, struct, or templated type."]
| (Ast.SynArrayType (dt,n))::rest ->
let t_n,_ = type_value_producer n env in
if t_n = TyInt then
(TyArray (type_data_type dt env))::(type_data_types rest env)
else
raise_type_error ["Invalid array index type ";string_of_type t_n;" expected an integer value."]
| (Ast.SynListType dt)::rest ->
(TyList (type_data_type dt env))::(type_data_types rest env)
| (Ast.SynRefType dt)::rest ->
(TyRef (type_data_type dt env))::(type_data_types rest env)
| (Ast.SynArrowType (arglist_types,ret_type))::rest ->
let arglist_types = type_data_types arglist_types env in
(TyArrow ((if arglist_types = [] then [TyVoid] else arglist_types),
type_data_type ret_type env))::(type_data_types rest env)
| [] -> []
and type_data_type dt env =
let verified_type_lst = type_data_types [dt] env in
match verified_type_lst with
x::rest -> x
| [] -> raise_type_error ["Unexpected type error."]
and structdef_list lst env = match lst with
(Ast.SynVarDeclareNoInit (dt,s))::[] -> [s,type_data_type dt env]
| (Ast.SynVarDeclareNoInit (dt,s))::rest -> (s,type_data_type dt env)::(structdef_list rest env)
| _ -> raise_type_error ["Expected uninitialized variable declaration in struct definition."]
and vardef_arglist arglist env =
match arglist with
(dt,name)::rest -> vardef_arglist rest ((TyVarDef (name,type_data_type dt env))::env)
| [] -> env
and type_value v env = match v with
Ast.SynIntValue _ -> TyInt, env
| Ast.SynFloatValue _ -> TyFloat, env
| Ast.SynBoolValue _ -> TyBool, env
| Ast.SynStringValue _ -> TyString, env
and string_of_type_list lst = match lst with
t::[] -> string_of_type t
| t::rest -> String.concat "" [string_of_type t;", ";string_of_type_list rest]
| [] -> ""
and are_assoclists_compatible l1 l2 = match l1 with
(x,y)::rest ->
if List.mem_assoc x l2
then y = List.assoc x l2
else are_assoclists_compatible rest l2
| [] -> true
and unify_types t1 t2 = match t1,t2 with
x,y when x = y -> []
| TyList t_list1, TyList t_list2 -> unify_types t_list1 t_list2
| TyArray t_arr1, TyArray t_arr2 -> unify_types t_arr1 t_arr2
| TyArrow (args1,ret1), TyArrow (args2,ret2) ->
let assoc1 = unify_types ret1 ret2 in
let assoc2 = List.flatten (List.map2 unify_types args1 args2) in
if are_assoclists_compatible assoc1 assoc2 then
assoc1 @ assoc2
else
raise_type_error ["Could not unify templated arrow type ";
string_of_type t2;
" with ";
string_of_type t1]
| TyRef t_ref1, TyRef t_ref2 -> unify_types t_ref1 t_ref2
| TyTemplate s, t2 -> [(s,t2)]
| _ -> raise_type_error ["Expected type ";
string_of_type t1;
" but got type ";
string_of_type t2]
and insert_template_types template_map env dt =
let insert_types = insert_template_types template_map env in
match dt with
TyList t -> TyList (insert_types t)
| TyArray t -> TyArray (insert_types t)
| TyArrow (args,ret) -> TyArrow (List.map insert_types args, insert_types ret)
| TyRef t -> TyRef (insert_types t)
| TyTemplate s ->
if List.mem_assoc s template_map then
List.assoc s template_map
else if isdef_templated s env then
TyTemplate s
else
raise_type_error ["Expression has free template type ";string_of_type dt;" in result."]
| x -> x
and apply_arrow_type arrowtype argtypes env =
let lhs_types, ret_type = match arrowtype with
TyArrow (x,y) -> x,y
| _ -> raise_type_error ["Attempted to apply arguments to something of non-arrow type ";string_of_type arrowtype;"."]
in
let isVoidArgs = lhs_types = [TyVoid] && (List.length argtypes = 0) in
let _ =
if (not isVoidArgs) && ((List.length lhs_types) != (List.length argtypes))
then raise_type_error ["Attempted to apply an incorrect number of arguments to arrow type ";string_of_type arrowtype;"."]
else ()
in
let template_map = ref [] in
let _ =
if isVoidArgs then () else
for i = 0 to (List.length lhs_types)-1 do
let cur_lhs, cur_arg = List.nth lhs_types i, List.nth argtypes i in
let unify_result = unify_types cur_lhs cur_arg in
if are_assoclists_compatible unify_result !template_map then
template_map := unify_result @ !template_map
else
raise_type_error ["Could not apply argument types ";
string_of_type_list argtypes;
" to a function of type ";
string_of_type arrowtype]
done
in
insert_template_types !template_map env ret_type
and type_function_call_value funcall env = match funcall with
Ast.SynLocalCall (s,vprod_list,isvar) ->
if isdef_fun s env || isdef_var s env then
let fun_type =
if isdef_fun s env then
gettype_fun s env
else
let _ = isvar := true in
gettype_var s env
in
let vplist_types,_ = type_value_producer_list_nonuniform vprod_list env in
try
apply_arrow_type fun_type vplist_types env, env
with
Type_error err_string ->
raise_type_error ["Call to (local) function ";s;" was malformed. ";err_string]
else
raise_type_error ["(Local) function call to undefined function ";s;"."]
| Ast.SynRemoteCall (s,vprod_list, var_ident) ->
let argtypes,_ = type_value_producer_list_nonuniform vprod_list env in
let rettype,_ = type_variable_identifier var_ident env in
let _ = append_link_buffer (concat ["require ";s;" = ";expanded_string_of_type (TyArrow (argtypes,rettype)) env;"\n";]) in
TyBool, env
| Ast.SynRemoteCallNoResult (s,vprod_list) ->
let argtypes,_ = type_value_producer_list_nonuniform vprod_list env in
let rettype = TyTemplate ("_unknown") in
let _ = append_link_buffer (concat ["require ";s;" = ";expanded_string_of_type (TyArrow (argtypes,rettype)) env;"\n";]) in
TyBool, env
and type_binop vp1 op vp2 env =
let t_vp1,_ = type_value_producer vp1 env in
let t_vp2,_ = type_value_producer vp2 env in
if isallowed_binop op t_vp1 t_vp2 then
(gettype_binop op t_vp1 t_vp2), env
else
raise_type_error ["Attempted to perform an invalid binary operation ";Ast.string_of_binop op;" on values of type ";string_of_type t_vp1;" and ";string_of_type t_vp2;"."]
and type_prefix_unop op vp env =
let t_vp,_ = type_value_producer vp env in
match (op,t_vp) with
Ast.SynUnopNot, TyBool -> TyBool, env
| Ast.SynUnopCar, TyList t_list -> t_list, env
| Ast.SynUnopCdr, TyList t_list -> TyList t_list, env
| Ast.SynUnopTrunc, (TyFloat | TyInt) -> TyInt, env
| Ast.SynUnopDeref, TyRef t_ref -> t_ref, env
| Ast.SynUnopNeg, TyInt -> TyInt, env
| Ast.SynUnopNeg, TyFloat -> TyFloat, env
| Ast.SynUnopNull, _ -> TyBool, env
| _ -> raise_type_error ["Attempted to perform an invalid prefix unary operation on a value of type ";string_of_type t_vp;"."]
and type_array_value_producer vp_list env = match vp_list with
vp::[] ->
let vp_type,_ = type_value_producer vp env in
TyArray vp_type, env
| vp::rest ->
let vp_type,_ = type_value_producer vp env in
let rest_type,_ = type_array_value_producer rest env in
(match rest_type with
TyArray rest_arr_type when rest_arr_type = vp_type ->
TyArray vp_type, env
| _ -> raise_type_error ["An element of type ";string_of_type vp_type;" is being used with an array of type ";string_of_type rest_type;"."])
| [] -> raise_type_error ["Constant array values must be non-empty."]
and type_value_producer_list vp_list env = match vp_list with
vp::[] ->
let vp_type,_ = type_value_producer vp env in
TyList vp_type, env
| vp::rest ->
let vp_type,_ = type_value_producer vp env in
let rest_type,_ = type_value_producer_list rest env in
if TyList vp_type = rest_type then
TyList vp_type, env
else
raise_type_error ["An element of type ";string_of_type vp_type;" is being used with list of type ";string_of_type rest_type;"."]
| [] -> raise_type_error ["Constant list values must be non-empty."]
and type_list_value_producer vp_list env = match vp_list with
Ast.SynListNil dt ->
let t_dt = type_data_type dt env in
TyList t_dt, env
| Ast.SynListList vp_list ->
type_value_producer_list vp_list env
| Ast.SynListCons (vp1,vp2) ->
let t_vp1,_ = type_value_producer vp1 env in
let t_vp2,_ = type_value_producer vp2 env in
(match t_vp2 with
TyList t_list when t_list = t_vp1 -> t_vp2, env
| _ -> raise_type_error ["Cannot cons a value of type ";string_of_type t_vp1;" to a list of type ";string_of_type t_vp2;"."])
and type_value_producer vp env = match vp with
Ast.SynValue v -> type_value v env
| Ast.SynFunctionCallValue funcall -> type_function_call_value funcall env
| Ast.SynVarIdentifier vident -> type_variable_identifier vident env
| Ast.SynBinop (vp1,op,vp2) -> type_binop vp1 op vp2 env
| Ast.SynPrefixUnop (op,vp) -> type_prefix_unop op vp env
| Ast.SynParenthesized vp -> type_value_producer vp env
| Ast.SynArrayValueProducer vp_list -> type_array_value_producer vp_list env
| Ast.SynListValueProducer vp_list -> type_list_value_producer vp_list env
and type_value_producer_list_nonuniform vp_list environment =
let helper vplist env =
match vplist with
vp::rest ->
let t_vp,_ = type_value_producer vp env in
let t_rest,_ = type_value_producer_list_nonuniform rest env in
t_vp::t_rest
| [] -> []
in
helper vp_list environment, environment
and type_variable_identifier v_ident env = match v_ident with
Ast.SynVarName s ->
if isdef_var s env then
gettype_var s env, env
else if isdef_enum s env then
TyEnumType s, env
else if isdef_struct s env then
TyStruct s, env
else if isdef_fun s env then
gettype_fun s env, env
else
raise_type_error ["Variable ";s;" was used but not defined."]
| Ast.SynStructOrEnumValue (vid1,s2,field_info) ->
let t_vid,_ = type_variable_identifier vid1 env in
(match t_vid with
TyEnumType s1 ->
if is_enum_value s1 s2 env then
let index = get_enum_value s1 s2 env in
let _ = field_info := (Ast.VIdEnumValue index) in
TyEnum s1, env
else
raise_type_error [s1;".";s2;" is not an enum value of enum type ";s1;"."]
| TyStruct s1 ->
if isdef_struct s1 env then
if is_struct_value s1 s2 env then
let index = getfield_struct s1 s2 env in
let _ = field_info := (Ast.VIdStructField index) in
gettype_struct s1 s2 env, env
else
raise_type_error [s1;".";s2;" refers to a non-existent field of struct type ";string_of_type t_vid;"."]
else
raise_type_error [s1;" is used as a struct but is not a struct."]
| _ -> raise_type_error ["An identifier of type ";string_of_type t_vid;" is not a struct or enum type in this scope."])
| Ast.SynArrayCell (vp,i) ->
let t,_ = type_variable_identifier vp env in
let t_index,_ = type_value_producer i env in
(match (t,t_index) with
TyArray t_arr, TyInt ->
t_arr, env
| _ -> raise_type_error ["A value of non-array-type ";string_of_type t;" is used as an array type."])