Commit af2321c6 authored by Martin Wierich's avatar Martin Wierich
Browse files

checking the kinds of all function-, instance-, class- and member-types

before typecheking (see new module "checkKindCorrectness")
parent dfa6cdce
......@@ -3,7 +3,7 @@ implementation module check
import StdEnv
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef
import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax
import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax, compilerSwitches
cPredefinedModuleIndex :== 1
cUndef :== (-1)
......@@ -392,7 +392,6 @@ where
cs_error = pushErrorAdmin (newPosition class_name ins_pos) cs.cs_error
(instance_type, _, type_heaps, Yes (modules, type_defs), Yes cs_error)
= determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes cs_error)
(type_defs, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n True me_symb instance_type type_defs modules cs_error
cs_error = popErrorAdmin cs_error
(st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type
......@@ -630,7 +629,6 @@ where
= pushErrorAdmin (newPosition class_name ins_pos) cs_error
(instance_type, new_ins_specials, type_heaps, Yes (modules, _), Yes cs_error)
= determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes (modules, {}, cUndef)) (Yes cs_error)
(_, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n False me_symb instance_type cDummyArray modules cs_error
cs_error
= popErrorAdmin cs_error
(new_info_ptr, var_heap) = newPtr VI_Empty var_heap
......@@ -669,54 +667,6 @@ where
= (tc_types, error)
checkTopLevelKinds :: !Index !Bool Ident !SymbolType n:{# CheckedTypeDef} !r:{# DclModule} !*ErrorAdmin
-> (!n:{# CheckedTypeDef}, !r:{# DclModule}, !*ErrorAdmin)
checkTopLevelKinds x_main_dcl_module_n is_icl_module me_symb st=:{st_args, st_result} type_defs modules cs_error
#! first_wrong = firstIndex (\{at_type} -> not (kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules 0 at_type)) [st_result:st_args]
# cs_error
= case first_wrong of
(-1)
-> cs_error
_
-> checkError "instance type has wrong kind"
( "(e.g. "
+++arg_string first_wrong
+++" of member "
+++toString me_symb
+++")"
)
cs_error
= (type_defs, modules, cs_error)
where
kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules demanded_kind type=:(TA {type_index={glob_object,glob_module}} args)
# {td_arity}
= if (glob_module==x_main_dcl_module_n && is_icl_module) type_defs.[glob_object]
modules.[glob_module].dcl_common.com_type_defs.[glob_object]
= demanded_kind == td_arity-length args
kind_is_ok _ _ _ modules 0 (_ --> _)
= True
kind_is_ok _ _ _ modules _ (_ :@: _)
= True
kind_is_ok _ _ _ _ 0 (TB _)
= True
kind_is_ok _ _ _ _ _ (GTV _)
= True
kind_is_ok _ _ _ _ _ (TV _)
= True
kind_is_ok _ _ _ _ _ (TQV _)
= True
kind_is_ok _ _ _ _ _ _
= False
consOptional (Yes thing) things
= [ thing : things]
consOptional No things
= things
initializeContextVariables :: ![TypeContext] !*VarHeap -> (![TypeContext], !*VarHeap)
initializeContextVariables contexts var_heap
= mapSt add_variable_to_context contexts var_heap
......
implementation module frontend
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics, convertimportedtypes
//import RWSDebug
import analtypes
import generics
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics,
convertimportedtypes, checkKindCorrectness, compilerSwitches, analtypes, generics
:: FrontEndSyntaxTree
= { fe_icl :: !IclModule
......@@ -127,6 +125,10 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
# error_admin = {ea_file = error, ea_loc = [], ea_ok = True }
# ti_common_defs = {{dcl_common \\ {dcl_common} <-: dcl_mods } & [main_dcl_module_n] = icl_common }
# (td_infos, type_heaps, error_admin) = analTypeDefs ti_common_defs icl_used_module_numbers type_heaps error_admin
(fun_defs, th_vars, td_infos, error_admin)
= checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances
ti_common_defs dcl_mods fun_defs type_heaps.th_vars td_infos error_admin
type_heaps = { type_heaps & th_vars = th_vars }
# heaps = { heaps & hp_type_heaps = type_heaps }
#! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) =
......
......@@ -2,7 +2,7 @@ implementation module type
import StdEnv
import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor // , RWSDebug
import cheat
import cheat, compilerSwitches
import generics // AA
:: TypeInput =
......@@ -863,17 +863,6 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index
(prop_class, th_vars, prop_td_infos) = propClassification glob_object glob_module props modules prop_type_heaps.th_vars prop_td_infos
(at_attribute, prop_class, th_attrs, prop_attr_vars, prop_attr_env, prop_error)
= determine_attribute_of_cons modules at_attribute cons_args prop_class prop_type_heaps.th_attrs prop_attr_vars prop_attr_env prop_error
({tdi_kinds}, prop_td_infos)
= prop_td_infos![glob_module,glob_object]
prop_error
= case prop_error of
No
// this function is called after typechecking (during transformations)
-> No
Yes error_admin
# (_, error_admin)
= unsafeFold2St (check_kind type_name modules) tdi_kinds cons_args (1, error_admin)
-> Yes error_admin
= ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute }, prop_class, { ps & prop_attr_vars = prop_attr_vars,
prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env,
prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error })
......@@ -935,39 +924,6 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index
combine_attributes cons_attr _ _ attr_var_heap attr_vars attr_env ps_error
= (cons_attr, attr_var_heap, attr_vars, attr_env, ps_error)
check_kind type_name modules type_kind {at_type} (arg_nr, error_admin)
# ok
= kind_is_ok modules (my_kind_to_int type_kind) at_type
| ok
= (arg_nr+1, error_admin)
# error_admin = errorHeading type_error error_admin
= (arg_nr+1, { error_admin & ea_file = error_admin.ea_file <<< " argument " <<< arg_nr <<< " of type " <<< type_name
<<< " expected kind " <<< type_kind <<< "\n" })
where
kind_is_ok modules demanded_kind (TA {type_index={glob_object,glob_module}} args)
# {td_arity}
= modules.[glob_module].com_type_defs.[glob_object]
= demanded_kind == td_arity-length args
kind_is_ok modules 0 (_ --> _)
= True
kind_is_ok modules _ (_ :@: _)
= True
kind_is_ok modules 0 (TB _)
= True
kind_is_ok modules _ (GTV _)
= True
kind_is_ok modules _ (TV _)
= True
kind_is_ok modules _ (TQV _)
= True
kind_is_ok modules _ _
= False
my_kind_to_int KindConst
= 0
my_kind_to_int (KindArrow k)
= length k
addPropagationAttributesToAType modules type=:{at_type} ps
# (at_type, ps) = addPropagationAttributesToType modules at_type ps
= ({ type & at_type = at_type }, NoPropClass, ps)
......
Supports Markdown
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