Skip to content
GitLab
Commit b2345e1b authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Sjaak: fixed inheritance bugs and strictness attributes

parent 3f236734
Hide whitespace changes
Inline Side-by-side
frontend/check.icl
View file @ b2345e1b
......@@ -32,9 +32,10 @@ checkGenerics
# cs = {cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
# type_heaps = {type_heaps & th_vars = th_vars}
/*
# (gen_type, specials, type_defs, class_defs, modules, type_heaps, cs) =
checkSymbolType module_index gen_type SP_None type_defs class_defs modules type_heaps cs
*/
# cs = {cs & cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope gen_args cs.cs_symbol_table}
# generic_defs = {generic_defs & [gen_index] = {gen_def & gen_type = gen_type, gen_args = gen_args}}
......@@ -57,41 +58,17 @@ where
checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps cs=:{cs_symbol_table,cs_error}
| class_index == size class_defs
= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
position = newPosition class_name class_pos
cs_error = setErrorAdmin position cs_error
(rev_class_args, cs_symbol_table, th_vars, cs_error)
= add_variables_to_symbol_table cGlobalScope class_args [] cs_symbol_table th_vars cs_error
cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
(class_context, type_defs, class_defs, modules, type_heaps, cs)
= checkTypeContexts class_context module_index type_defs class_defs modules { type_heaps & th_vars = th_vars } cs
(class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
cs = {cs & cs_error = setErrorAdmin (newPosition class_name class_pos) cs_error }
(class_args, class_context, type_defs, class_defs, modules, type_heaps, cs)
= checkSuperClasses class_args class_context module_index type_defs class_defs modules type_heaps cs
class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }}
member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs
= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table }
= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps cs
where
add_variables_to_symbol_table :: !Level ![TypeVar] ![TypeVar] !*SymbolTable !*TypeVarHeap !*ErrorAdmin
-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error
= (rev_class_args, symbol_table, th_vars, error)
add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error
# (entry, symbol_table) = readPtr id_info symbol_table
| entry.ste_kind == STE_Empty || entry.ste_def_level < level
# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry
= add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error
= add_variables_to_symbol_table level vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error)
retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
# (entry, symbol_table) = readPtr id_info symbol_table
= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
retrieve_variables_from_symbol_table [] class_args symbol_table
= (class_args, symbol_table)
set_classes_in_member_defs mem_offset class_members glob_class_index member_defs
| mem_offset == size class_members
= member_defs
......@@ -99,7 +76,6 @@ where
# (member_def, member_defs) = member_defs![ds_index]
= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }}
checkSpecial :: !Index !FunType !Index !SpecialSubstitution (!Index, ![FunType], !*Heaps, !*ErrorAdmin)
-> (!Special, (!Index, ![FunType], !*Heaps, !*ErrorAdmin))
checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, special_types, heaps, error)
......@@ -131,7 +107,7 @@ where
# position = newPosition ft_symb ft_pos
cs = { cs & cs_error = setErrorAdmin position cs.cs_error }
(ft_type, ft_specials, type_defs, class_defs, modules, hp_type_heaps, cs)
= checkSymbolType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
= checkFunctionType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
(spec_types, next_inst_index, collected_instances, heaps, cs_error)
= check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances
{ heaps & hp_type_heaps = hp_type_heaps } cs.cs_error
......@@ -198,13 +174,13 @@ where
# (member_def=:{me_symb,me_type,me_pos}, member_defs) = member_defs![member_index]
position = newPosition me_symb me_pos
cs = { cs & cs_error = setErrorAdmin position cs.cs_error }
(me_type, _, type_defs, class_defs, modules, type_heaps, cs)
= checkSymbolType module_index me_type SP_None type_defs class_defs modules type_heaps cs
me_class_vars = map (\(TV type_var) -> type_var) (hd me_type.st_context).tc_types
(me_type, type_defs, class_defs, modules, type_heaps, cs)
= checkMemberType module_index me_type type_defs class_defs modules type_heaps cs
me_class_vars = [ type_var \\ (TV type_var) <- (hd me_type.st_context).tc_types ]
(me_type_ptr, var_heap) = newPtr VI_Empty var_heap
= ({ member_defs & [member_index] = { member_def & me_type = me_type, me_class_vars = me_class_vars, me_type_ptr = me_type_ptr }},
type_defs, class_defs, modules, type_heaps, var_heap, cs)
:: InstanceSymbols =
{ is_type_defs :: !.{# CheckedTypeDef}
, is_class_defs :: !.{# ClassDef}
......@@ -696,8 +672,9 @@ checkFunction mod_index fun_index def_level fun_defs
(ef_type_defs, ef_modules, es_type_heaps, es_expr_heap, cs) =
checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expr_heap cs
cs = { cs & cs_error = popErrorAdmin cs.cs_error }
fi_properties = (if ef_is_macro_fun FI_IsMacroFun 0) bitor (has_type fun_type)
fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics,
fi_is_macro_fun = ef_is_macro_fun }
fi_properties = fi_properties }
fun_defs = { es_fun_defs & [fun_index] = { fun_def & fun_body = fun_body, fun_index = fun_index, fun_info = fun_info, fun_type = fun_type}}
(fun_defs, cs_symbol_table) = remove_calls_from_symbol_table fun_index def_level es_calls fun_defs cs.cs_symbol_table
= (fun_defs,
......@@ -706,8 +683,11 @@ checkFunction mod_index fun_index def_level fun_defs
{ cs & cs_symbol_table = cs_symbol_table })
where
has_type (Yes _) = FI_HasTypeSpec
has_type no = 0
check_function_type (Yes ft) module_index type_defs class_defs modules var_heap type_heaps cs
# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkSymbolType module_index ft SP_None type_defs class_defs modules type_heaps cs
# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkFunctionType module_index ft SP_None type_defs class_defs modules type_heaps cs
(st_context, var_heap) = initializeContextVariables ft.st_context var_heap
= (Yes { ft & st_context = st_context } , type_defs, class_defs, modules, var_heap, type_heaps, cs)
......
frontend/checkFunctionBodies.icl
View file @ b2345e1b
......@@ -959,12 +959,12 @@ where
-> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState)
determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info
e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info cs=:{cs_symbol_table,cs_x}
# ({fun_symb,fun_arity,fun_kind,fun_priority,fun_info}, es_fun_defs) = es_fun_defs![ste_index]
# ({fun_symb,fun_arity,fun_kind,fun_priority,fun_info={fi_properties}}, es_fun_defs) = es_fun_defs![ste_index]
# index = { glob_object = ste_index, glob_module = cs_x.x_main_dcl_module_n }
| is_called_before ei_fun_index calls
| case fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False
= (SK_Macro index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs)
# symbol_kind = if fun_info.fi_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index)
# symbol_kind = if (fi_properties bitand FI_IsMacroFun <> 0) (SK_LocalMacroFunction ste_index) (SK_Function index)
= (symbol_kind, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs)
# cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})}
e_state = { e_state & es_fun_defs = es_fun_defs, es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]}
......@@ -974,7 +974,7 @@ where
FK_ImpMacro
-> SK_Macro index;
_
| fun_info.fi_is_macro_fun
| fi_properties bitand FI_IsMacroFun <> 0
-> SK_LocalMacroFunction ste_index
-> SK_Function index
= (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs)
......
frontend/checksupport.icl
View file @ b2345e1b
......@@ -308,7 +308,7 @@ addLocalFunctionDefsToSymbolTable level from_index to_index is_macro_fun fun_def
# (fun_def, fun_defs) = fun_defs![from_index]
# (symbol_table, error) = addDefToSymbolTable level from_index fun_def.fun_symb (STE_FunctionOrMacro []) symbol_table error
| is_macro_fun
# fun_defs = {fun_defs & [from_index].fun_info.fi_is_macro_fun=is_macro_fun}
# fun_defs = {fun_defs & [from_index].fun_info.fi_properties = fun_def.fun_info.fi_properties bitor FI_IsMacroFun }
= addLocalFunctionDefsToSymbolTable level (inc from_index) to_index is_macro_fun fun_defs symbol_table error
= addLocalFunctionDefsToSymbolTable level (inc from_index) to_index is_macro_fun fun_defs symbol_table error
......
frontend/checktypes.dcl
View file @ b2345e1b
......@@ -5,15 +5,18 @@ import checksupport, typesupport
checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState)
......
frontend/checktypes.icl
View file @ b2345e1b
......@@ -674,15 +674,16 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
= check_fully_polymorphity it_types it_context cs.cs_error
ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
(it_types, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error })
(it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs
cs_error
= foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error
(it_types, (ots, oti=:{oti_all_vars = it_vars, oti_all_attrs = it_attr_vars}, cs))
= checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error })
oti = { oti & oti_all_vars = [], oti_all_attrs = [] }
(it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index class_defs ots oti cs
cs_error = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error
(specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error }
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope it_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable it_attr_vars cs_symbol_table
(specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
= ({it & it_vars = oti_all_vars, it_types = it_types, it_attr_vars = oti_all_attrs, it_context = it_context },
= ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context },
specials, type_defs, class_defs, modules, heaps, cs)
where
check_fully_polymorphity it_types it_context cs_error
......@@ -715,32 +716,37 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
compare_context_and_instance_type _ _ are_equal_accu
= False
checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkFunctionType mod_index st specials type_defs class_defs modules heaps cs
= checkSymbolType True mod_index st specials type_defs class_defs modules heaps cs
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkMemberType mod_index st type_defs class_defs modules heaps cs
# (checked_st, specials, type_defs, class_defs, modules, heaps, cs)
= checkSymbolType False mod_index st SP_None type_defs class_defs modules heaps cs
= (checked_st, type_defs, class_defs, modules, heaps, cs)
checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
checkSymbolType :: !Bool !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSymbolType mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs
checkSymbolType is_function mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs
# ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
(st_args, cot_state) = checkOpenATypes mod_index cGlobalScope st_args (ots, oti, cs)
(st_result, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state
(st_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts st_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs
(st_attr_env, cs) = check_attr_inequalities st_attr_env cs
(st_result, (ots, oti=:{oti_all_vars = st_vars,oti_all_attrs = st_attr_vars}, cs))
= checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state
oti = { oti & oti_all_vars = [], oti_all_attrs = [] }
(st_context, type_defs, class_defs, modules, heaps, cs) = check_type_contexts is_function st_context mod_index class_defs ots oti cs
(st_attr_env, cs) = mapSt check_attr_inequality st_attr_env cs
(specials, cs) = checkSpecialTypeVars specials cs
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope st_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable st_attr_vars cs_symbol_table
(specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
checked_st = {st & st_vars = oti_all_vars, st_args = st_args, st_result = st_result, st_context = st_context,
st_attr_vars = oti_all_attrs, st_attr_env = st_attr_env }
checked_st = {st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_context = st_context,
st_attr_vars = st_attr_vars, st_attr_env = st_attr_env }
= (checked_st, specials, type_defs, class_defs, modules, heaps, cs)
// ---> ("checkSymbolType", st, checked_st)
where
check_attr_inequalities [ineq : ineqs] cs
# (ineq, cs) = check_attr_inequality ineq cs
(ineqs, cs) = check_attr_inequalities ineqs cs
= ([ineq : ineqs], cs)
check_attr_inequalities [] cs
= ([], cs)
check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_name=dem_name},ai_offered=ai_offered=:{av_name=off_name}} cs=:{cs_symbol_table,cs_error}
# (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table
# (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry
......@@ -752,46 +758,75 @@ where
{ cs & cs_symbol_table = cs_symbol_table })
= (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table })
= (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table })
retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index}
| ste_def_level == cGlobalScope
= (True, attr_ptr)
retrieve_attribute entry
= (False, abort "no attribute")
checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkTypeContexts [tc : tcs] mod_index type_defs class_defs modules heaps cs
# (tc, type_defs, class_defs, modules, heaps, cs) = check_type_context tc mod_index type_defs class_defs modules heaps cs
(tcs, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts tcs mod_index type_defs class_defs modules heaps cs
= ([tc : tcs], type_defs, class_defs, modules, heaps, cs)
where
retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index}
| ste_def_level == cGlobalScope
= (True, attr_ptr)
retrieve_attribute entry
= (False, abort "no attribute")
check_type_contexts is_function st_context mod_index class_defs ots oti cs
| is_function
= checkTypeContexts st_context mod_index class_defs ots oti cs
= check_member_contexts st_context mod_index class_defs ots oti cs
check_member_contexts [tc : tcs] mod_index class_defs ots oti cs
# (tc, (class_defs, ots, oti, cs)) = checkTypeContext mod_index tc (class_defs, ots, oti, cs)
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope [ tv \\ (TV tv) <- tc.tc_types] cs.cs_symbol_table
(tcs, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts tcs mod_index class_defs ots oti { cs & cs_symbol_table = cs_symbol_table }
= ([tc : tcs], type_defs, class_defs, modules, heaps, cs)
NewEntry symbol_table symb_ptr def_kind def_index level previous :==
symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous })
checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses class_args class_contexts mod_index type_defs class_defs modules heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
# (rev_class_args, cs_symbol_table, th_vars, cs_error)
= foldSt add_variable_to_symbol_table class_args ([], cs_symbol_table, th_vars, cs_error)
cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
ots = { ots_modules = modules, ots_type_defs = type_defs }
oti = { oti_heaps = { heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(class_contexts, type_defs, class_defs, modules, type_heaps, cs)
= checkTypeContexts class_contexts mod_index class_defs ots oti cs
(class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
= (class_args, class_contexts, type_defs, class_defs, modules, type_heaps, {cs & cs_symbol_table = cs_symbol_table})
where
check_type_context :: !TypeContext !Index v:{#CheckedTypeDef} !x:{#ClassDef} !u:{#.DclModule} !*TypeHeaps !*CheckState
-> (!TypeContext,!z:{#CheckedTypeDef},!x:{#ClassDef},!w:{#DclModule},!*TypeHeaps,!*CheckState), [u v <= w, v u <= z]
check_type_context tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types}
mod_index type_defs class_defs modules heaps cs=:{cs_symbol_table, cs_predef_symbols}
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
cs = { cs & cs_symbol_table = cs_symbol_table }
# (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index
| class_index <> NotFound
# (class_def, class_index, class_defs, modules) = getClassDef class_index class_module mod_index class_defs modules
ots = { ots_modules = modules, ots_type_defs = type_defs }
oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(tc_types, (ots, {oti_all_vars,oti_all_attrs,oti_heaps}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
cs = check_context_types class_def.class_name tc_types cs
cs = foldr (\ {tv_name} cs=:{cs_symbol_table,cs_error} ->
{ cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table,
cs_error = checkError tv_name " undefined" cs_error}) cs oti_all_vars
cs = foldr (\ {av_name} cs=:{cs_symbol_table,cs_error} ->
{ cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table,
cs_error = checkError av_name " undefined" cs_error}) cs oti_all_attrs
tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types}
| class_def.class_arity == ds_arity
= (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, cs)
= (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })
= (tc, type_defs, class_defs, modules, heaps, { cs & cs_error = checkError id_name "undefined" cs.cs_error })
add_variable_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin)
-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_variable_to_symbol_table tv=:{tv_name={id_name,id_info}} (rev_class_args, symbol_table, th_vars, error)
# (entry, symbol_table) = readPtr id_info symbol_table
| entry.ste_kind == STE_Empty || entry.ste_def_level < cGlobalScope
# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex cGlobalScope entry
= ([{ tv & tv_info_ptr = new_var_ptr} : rev_class_args], symbol_table, th_vars, error)
= (rev_class_args, symbol_table, th_vars, checkError id_name "(variable) already defined" error)
retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
# (entry, symbol_table) = readPtr id_info symbol_table
= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
retrieve_variables_from_symbol_table [] class_args symbol_table
= (class_args, symbol_table)
checkTypeContext :: !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types}
(class_defs, ots, oti, cs=:{cs_symbol_table, cs_predef_symbols})
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
cs = { cs & cs_symbol_table = cs_symbol_table }
# (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index
| class_index <> NotFound
# (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules
ots = { ots & ots_modules = ots_modules }
(tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
cs = check_context_types class_def.class_name tc_types cs
tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types}
| class_def.class_arity == ds_arity
= (tc, (class_defs, ots, oti, cs))
= (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }))
= (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error }))
where
check_context_types tc_class [] cs=:{cs_error}
= { cs & cs_error = checkError tc_class " type context should contain one or more type variables" cs_error}
check_context_types tc_class [TV _ : types] cs
......@@ -799,8 +834,28 @@ where
check_context_types tc_class [type : types] cs
= check_context_types tc_class types cs
checkTypeContexts [] _ type_defs class_defs modules heaps cs
= ([], type_defs, class_defs, modules, heaps, cs)
checkTypeContexts :: ![TypeContext] !Index !v:{# ClassDef} !u:OpenTypeSymbols !*OpenTypeInfo !*CheckState
-> (![TypeContext], !u:{# CheckedTypeDef}, !v:{# ClassDef}, u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkTypeContexts tcs mod_index class_defs ots oti cs
# (tcs, (class_defs, { ots_modules, ots_type_defs}, oti, cs)) = mapSt (checkTypeContext mod_index) tcs (class_defs, ots, oti, cs)
cs = check_class_variables oti.oti_all_vars cs
cs = check_class_attributes oti.oti_all_attrs cs
= (tcs, ots_type_defs, class_defs, ots_modules, oti.oti_heaps, cs)
where
check_class_variables class_variables cs
= foldSt check_class_variable class_variables cs
where
check_class_variable {tv_name} cs=:{cs_symbol_table,cs_error}
= { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table,
cs_error = checkError tv_name " not defined or defined as class variable" cs_error}
check_class_attributes class_attributes cs
= foldSt check_class_attribute class_attributes cs
where
check_class_attribute {av_name} cs=:{cs_symbol_table,cs_error}
= { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table,
cs_error = checkError av_name " undefined" cs_error}
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState)
......@@ -831,6 +886,8 @@ where
| entry.ste_kind == STE_Empty
= symbol_table
= symbol_table <:= (id_info, entry.ste_previous)
checkDynamicTypes mod_index dyn_type_ptrs (Yes {st_vars}) type_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
# (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table)
......
frontend/comparedefimp.icl
View file @ b2345e1b
......@@ -252,7 +252,8 @@ compareTwoMacroFuns dclIndex iclIndex
ident_pos = getIdentPos dcl_function
ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
ec_state = { ec_state & ec_error_admin = ec_error_admin }
| dcl_function.fun_info.fi_is_macro_fun<>icl_function.fun_info.fi_is_macro_fun ||
// Sjaak : | dcl_function.fun_info.fi_is_macro_fun<>icl_function.fun_info.fi_is_macro_fun ||
| dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun ||
dcl_function.fun_priority<>icl_function.fun_priority
# ec_state = give_error dcl_function.fun_symb ec_state
= { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin }
......
frontend/convertDynamics.icl
View file @ b2345e1b
......@@ -68,7 +68,6 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules
// TD ...
# tcl_file
= case tcl_file of
......@@ -83,7 +82,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
// ... TD
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics]
#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
= case (pds_module == (-1) || pds_def == (-1)) of
......
frontend/convertcases.icl
View file @ b2345e1b
......@@ -468,6 +468,8 @@ toOptionalFreeVar No var_heap
:: ImportedFunctions :== [Global Index]
cDontRemoveAnnatations :== False
addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap
-> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
addNewFunctionsToGroups common_defs fun_heap new_functions main_dcl_module_n groups imported_types imported_conses type_heaps var_heap
......@@ -479,11 +481,13 @@ where
-> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
add_new_function_to_group fun_heap common_defs fun_ptr (groups, fun_defs, imported_types, imported_conses, type_heaps, var_heap)
# (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap
group_index = gf_fun_def.fun_info.fi_group_index
{fun_type = Yes ft, fun_info = {fi_group_index, fi_properties}} = gf_fun_def
(Yes ft) = gf_fun_def.fun_type
(ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft main_dcl_module_n imported_types imported_conses type_heaps var_heap
# (group, groups) = groups![group_index]
= ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} },
(ft, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType (fi_properties bitand FI_HasTypeSpec == 0) common_defs ft main_dcl_module_n
imported_types imported_conses type_heaps var_heap
# (group, groups) = groups![fi_group_index]
= ({ groups & [fi_group_index] = { group & group_members = [gf_fun_index : group.group_members]} },
[ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap)
convertCasesOfFunctionsIntoPatterns :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}}
......@@ -572,7 +576,7 @@ where
convert_dcl_function dcl_functions common_defs dcl_index (imported_types, imported_conses, var_heap, type_heaps)
# {ft_type, ft_type_ptr} = dcl_functions.[dcl_index]
(ft_type, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= convertSymbolType cDontRemoveAnnatations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= (imported_types, imported_conses, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type), type_heaps)
convertConstructorTypes cons_defs main_dcl_module_n common_defs types_and_heaps
......@@ -581,7 +585,7 @@ where
convert_constructor_type common_defs cons_defs cons_index (imported_types, imported_conses, var_heap, type_heaps)
# {cons_type_ptr, cons_type} = cons_defs.[cons_index]
(cons_type, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= convertSymbolType cDontRemoveAnnatations common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= (imported_types, imported_conses, var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type), type_heaps)
......@@ -591,7 +595,7 @@ where
convert_selector_type common_defs selector_defs sel_index (imported_types, imported_conses, var_heap, type_heaps)
# {sd_type_ptr, sd_type} = selector_defs.[sel_index]
(sd_type, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= convertSymbolType cDontRemoveAnnatations common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= (imported_types, imported_conses, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type), type_heaps)
convertIclModule :: !Int !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps
......@@ -641,7 +645,7 @@ where
convert_imported_function dcl_functions common_defs {glob_object,glob_module} (imported_types, imported_conses, type_heaps, var_heap)
# {ft_type_ptr,ft_type} = dcl_functions.[glob_module].[glob_object]
(ft_type, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= convertSymbolType cDontRemoveAnnatations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap
= (imported_types, imported_conses, type_heaps, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type))
convert_imported_constructors common_defs [] imported_types type_heaps var_heap
......@@ -649,7 +653,8 @@ where
convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap
# {com_cons_defs,com_selector_defs} = common_defs.[glob_module]
{cons_type_ptr,cons_type,cons_type_index,cons_symb} = common_defs.[glob_module].com_cons_defs.[glob_object]
(cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type main_dcl_module_n imported_types conses type_heaps var_heap
(cons_type, imported_types, conses, type_heaps, var_heap)
</