Commit bc57978c authored by John van Groningen's avatar John van Groningen
Browse files

use type FunSpecials instead of Specials for specials of functions

(to have fewer differences with the haskell frontend branch)
parent 3f2bc485
......@@ -15,7 +15,7 @@ checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !p:Predefined
-> (!*ErrorAdmin,!p:PredefinedSymbols,!*{#FunDef})
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
......
......@@ -50,7 +50,7 @@ checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, spe
ft_type = { special_type & st_context = [] }
(new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap
= ( { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs },
((inc next_inst_index), [{ fun_type & ft_type = ft_type, ft_specials = SP_FunIndex fun_index, ft_type_ptr = new_info_ptr} : special_types ],
((inc next_inst_index), [{ fun_type & ft_type = ft_type, ft_specials = FSP_FunIndex fun_index, ft_type_ptr = new_info_ptr} : special_types ],
{ heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, predef_symbols, error))
where
substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps error
......@@ -82,14 +82,14 @@ where
{ fun_type & ft_type = ft_type, ft_specials = spec_types, ft_type_ptr = new_info_ptr } : collected_funtypes]
collected_instances type_defs class_defs modules { heaps & hp_var_heap = hp_var_heap } { cs & cs_predef_symbols=cs_predef_symbols,cs_error = cs_error }
check_specials :: !Index !FunType !Index !Specials !Index ![FunType] !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!Specials, !Index, ![FunType], !*Heaps, !*PredefinedSymbols, !*ErrorAdmin)
check_specials mod_index fun_type fun_index (SP_Substitutions substs) next_inst_index all_instances heaps predef_symbols error
check_specials :: !Index !FunType !Index !FunSpecials !Index ![FunType] !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!FunSpecials, !Index,![FunType],!*Heaps,!*PredefinedSymbols,!*ErrorAdmin)
check_specials mod_index fun_type fun_index (FSP_Substitutions substs) next_inst_index all_instances heaps predef_symbols error
# (list_of_specials, (next_inst_index, all_instances, heaps, cs_predef_symbols,cs_error))
= mapSt (checkSpecial mod_index fun_type fun_index) substs (next_inst_index, all_instances, heaps, predef_symbols,error)
= (SP_ContextTypes list_of_specials, next_inst_index, all_instances, heaps, cs_predef_symbols,cs_error)
check_specials mod_index fun_type fun_index SP_None next_inst_index all_instances heaps predef_symbols error
= (SP_None, next_inst_index, all_instances, heaps, predef_symbols,error)
= (FSP_ContextTypes list_of_specials, next_inst_index, all_instances, heaps, cs_predef_symbols,cs_error)
check_specials mod_index fun_type fun_index FSP_None next_inst_index all_instances heaps predef_symbols error
= (FSP_None, next_inst_index, all_instances, heaps, predef_symbols,error)
checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*PredefinedSymbols,!*ErrorAdmin)
......@@ -118,7 +118,7 @@ where
spec_member_index = member_index - first_mem_index
# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
# mem_inst = inst_spec_defs.[spec_member_index]
(SP_Substitutions specials) = mem_inst.ft_specials
(FSP_Substitutions specials) = mem_inst.ft_specials
env = specials !! type_offset
member = {member & cim_index = next_inst_index}
(spec_type, (next_inst_index, all_specials, heaps, predef_symbols,error))
......@@ -272,7 +272,6 @@ where
= check_icl_instance_members module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_ident ins_pos ins_type
[ (ins_member.cim_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error }
getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule})
getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules
| glob_module == mod_index
......@@ -381,7 +380,7 @@ where
= ({ bind & bind_dst = new_tv }, type_var_heap)
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_modules error
# env = { ss_environ = foldl2 (\binds var type -> [ {bind_src = type, bind_dst = var} : binds]) [] class_vars it_types,
ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars}
......@@ -394,11 +393,11 @@ where
determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps error
# (mem_st, substs, type_heaps, error)
= substitute_symbol_type { mem_st & st_context = tl st_context } env substs type_heaps error
= (mem_st, SP_Substitutions substs, type_heaps, error)
= (mem_st, FSP_Substitutions substs, type_heaps, error)
determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps error
# (mem_st, _, type_heaps, error)
= substitute_symbol_type { mem_st & st_context = tl st_context } env [] type_heaps error
= (mem_st, SP_None, type_heaps, error)
= (mem_st, FSP_None, type_heaps, error)
substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps error
# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, error)
......@@ -771,7 +770,7 @@ where
has_type no = 0
check_function_type (Yes ft) module_index is_caf type_defs class_defs modules var_heap 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
# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkFunctionType module_index ft FSP_None type_defs class_defs modules type_heaps cs
cs = (if is_caf (check_caf_uniqueness ft.st_result.at_attribute) id) 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)
......@@ -2390,7 +2389,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
where
collect_specialized_functions spec_index last_index dcl_fun_types (icl_functions, heaps)
| spec_index < last_index
# {ft_type,ft_specials = SP_FunIndex decl_index} = dcl_fun_types.[spec_index]
# {ft_type,ft_specials = FSP_FunIndex decl_index} = dcl_fun_types.[spec_index]
// icl_index = conversion_table.[decl_index]
icl_index = decl_index
(icl_fun, icl_functions) = icl_functions![icl_index]
......@@ -2906,7 +2905,7 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
# dcl_functions
= arrayPlusList dcl_functions
( [ { mem_inst & ft_specials = if (isEmpty spec_types) SP_None (SP_ContextTypes spec_types) }
( [ { mem_inst & ft_specials = if (isEmpty spec_types) FSP_None (FSP_ContextTypes spec_types) }
\\ mem_inst <- memb_inst_defs & spec_types <-: all_spec_types
]
++ reverse rev_special_defs
......@@ -3229,7 +3228,6 @@ where
(<<<) file (SP_ParsedSubstitutions _) = file <<< "SP_ParsedSubstitutions"
(<<<) file (SP_Substitutions substs) = file <<< "SP_Substitutions " <<< substs
(<<<) file (SP_ContextTypes specials) = file <<< "SP_ContextTypes " <<< specials
(<<<) file (SP_FunIndex _) = file <<< "SP_ParsedSubstitutions"
(<<<) file SP_None = file <<< "SP_None"
instance <<< Special
......
......@@ -51,8 +51,8 @@ where
{heaps & hp_generic_heap = hp_generic_heap})
check_generic_type gen_def=:{gen_type, gen_vars, gen_ident, gen_pos} module_index type_defs class_defs modules heaps=:{hp_type_heaps} cs
#! (checked_gen_type, _, type_defs, class_defs, modules, hp_type_heaps, cs) =
checkFunctionType module_index gen_type SP_None type_defs class_defs modules hp_type_heaps cs
#! (checked_gen_type, _, type_defs, class_defs, modules, hp_type_heaps, cs)
= checkFunctionType module_index gen_type FSP_None type_defs class_defs modules hp_type_heaps cs
#! (checked_gen_vars, cs) = check_generic_vars gen_vars checked_gen_type.st_vars cs
#! checked_gen_type = { checked_gen_type & st_vars = move_gen_vars checked_gen_vars checked_gen_type.st_vars}
......@@ -272,15 +272,13 @@ where
# gencase_defs = {gencase_defs & [gc_index] = gencase_def}
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
#! fun =
{ ft_ident = fun_ident
, ft_arity = 0
, ft_priority = NoPrio
, ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict}
, ft_pos = gc_pos
, ft_specials = SP_None
, ft_type_ptr = var_info_ptr
}
#! fun = { ft_ident = fun_ident
, ft_arity = 0
, ft_priority = NoPrio
, ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict}
, ft_pos = gc_pos
, ft_specials = FSP_None
, ft_type_ptr = var_info_ptr }
= (fun, gencase_defs, hp_var_heap)
NewEntry symbol_table symb_ptr def_kind def_index level previous :==
......
......@@ -5,8 +5,8 @@ import checksupport, typesupport
checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int)) !*{# CheckedTypeDef} !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*Heaps !*CheckState
-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*Heaps, !*CheckState)
checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !FunSpecials,!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)
......
......@@ -612,6 +612,7 @@ where
= (TA_Multi, error)
determine_attribute var_ident dem_attr new_attr error
= (new_attr, error)
check_attribute var_ident dem_attr _ this_attr oti cs
= (TA_Multi, oti, cs)
......@@ -829,23 +830,21 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
= ti1==ti2 && are_equal_accu
compare_context_and_instance_type (_ --> _) (_ --> _) are_equal_accu
= are_equal_accu
//AA..
compare_context_and_instance_type TArrow TArrow are_equal_accu
= are_equal_accu
compare_context_and_instance_type (TArrow1 _) (TArrow1 _) are_equal_accu
= are_equal_accu
//..AA
compare_context_and_instance_type (CV tv1 :@: _) (CV tv2 :@: _) are_equal_accu
= tv1==tv2 && are_equal_accu
compare_context_and_instance_type (TB bt1) (TB bt2) are_equal_accu
= bt1==bt2 && are_equal_accu
compare_context_and_instance_type (TV tv1) (TV tv2) are_equal_accu
= tv1==tv2 && are_equal_accu
compare_context_and_instance_type (CV tv1 :@: _) (CV tv2 :@: _) are_equal_accu
= tv1==tv2 && are_equal_accu
compare_context_and_instance_type TArrow TArrow are_equal_accu
= are_equal_accu
compare_context_and_instance_type (TArrow1 _) (TArrow1 _) are_equal_accu
= are_equal_accu
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 :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !FunSpecials,!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
......@@ -853,29 +852,27 @@ checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{
-> (!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
= checkSymbolType False mod_index st FSP_None type_defs class_defs modules heaps cs
= (checked_st, type_defs, class_defs, modules, heaps, cs)
checkSymbolType :: !Bool !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,!Specials,!u:{# CheckedTypeDef},!v:{# ClassDef},!u:{# DclModule},!*TypeHeaps,!*CheckState)
checkSymbolType :: !Bool !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
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)
// ---> ("checkSymbolType", st_args))
(st_result, (ots, oti=:{oti_all_vars = st_vars,oti_all_attrs = st_attr_vars,oti_global_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
(specials, cs) = checkFunSpecialTypeVars specials cs
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 }
(specials, type_defs, modules, heaps, cs) = checkFunSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
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", checked_st)
where
check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_ident=dem_name},ai_offered=ai_offered=:{av_ident=off_name}} cs=:{cs_symbol_table,cs_error}
# (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table
......@@ -1077,9 +1074,7 @@ 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)
(type_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs modules
......@@ -1201,14 +1196,23 @@ checkSpecialTypeVars :: !Specials !*CheckState -> (!Specials, !*CheckState)
checkSpecialTypeVars (SP_ParsedSubstitutions env) cs
# (env, cs) = mapSt check_type_vars env cs
= (SP_ParsedSubstitutions env, cs)
checkSpecialTypeVars SP_None cs
= (SP_None, cs)
checkFunSpecialTypeVars :: !FunSpecials !*CheckState -> (!FunSpecials, !*CheckState)
checkFunSpecialTypeVars (FSP_ParsedSubstitutions env) cs
# (env, cs) = mapSt check_type_vars env cs
= (FSP_ParsedSubstitutions env, cs)
checkFunSpecialTypeVars FSP_None cs
= (FSP_None, cs)
check_type_vars [] cs
= ([],cs)
check_type_vars [bind:binds] cs
# (bind,cs) = check_type_var bind binds cs
# (binds,cs) = check_type_vars binds cs
= ([bind:binds],cs)
where
check_type_vars [] cs
= ([],cs)
check_type_vars [bind:binds] cs
# (bind,cs) = check_type_var bind binds cs
# (binds,cs) = check_type_vars binds cs
= ([bind:binds],cs)
check_type_var bind=:{bind_dst=type_var=:{tv_ident={id_name,id_info}}} binds cs=:{cs_symbol_table,cs_error}
# ({ste_kind,ste_def_level}, cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind <> STE_Empty && ste_def_level == cGlobalScope
......@@ -1222,29 +1226,37 @@ where
= id_info==bind_dst.tv_ident.id_info || id_info_occurs_in_list id_info l
id_info_occurs_in_list id_info []
= False
checkSpecialTypeVars SP_None cs
= (SP_None, cs)
checkSpecialTypes :: !Index !Specials !v:{#CheckedTypeDef} !u:{#.DclModule} !*TypeHeaps !*CheckState
-> (!Specials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];
checkSpecialTypes :: !Index !Specials !v:{#CheckedTypeDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!Specials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];
checkSpecialTypes mod_index (SP_ParsedSubstitutions envs) type_defs modules heaps cs
# ots = { ots_type_defs = type_defs, ots_modules = modules }
(specials, (heaps, ots, cs)) = mapSt (check_environment mod_index) envs (heaps, ots, cs)
= (SP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs)
where
check_environment mod_index env (heaps, ots, cs)
# oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(env, (ots, {oti_heaps,oti_all_vars,oti_all_attrs,oti_global_vars}, cs)) = mapSt (check_substituted_type mod_index) env (ots, oti, cs)
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table
cs = check_no_global_type_vars oti_global_vars {cs & cs_symbol_table = cs_symbol_table}
= ({ ss_environ = env, ss_context = [], ss_vars = oti_all_vars, ss_attrs = oti_all_attrs}, (oti_heaps, ots, cs))
checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
checkFunSpecialTypes :: !Index !FunSpecials !v:{#CheckedTypeDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!FunSpecials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];
checkFunSpecialTypes mod_index (FSP_ParsedSubstitutions envs) type_defs modules heaps cs
# ots = { ots_type_defs = type_defs, ots_modules = modules }
(specials, (heaps, ots, cs)) = mapSt (check_environment mod_index) envs (heaps, ots, cs)
= (FSP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs)
checkFunSpecialTypes mod_index FSP_None type_defs modules heaps cs
= (FSP_None, type_defs, modules, heaps, cs)
check_environment :: Int (Env Type TypeVar) *(*TypeHeaps,u:OpenTypeSymbols,*CheckState) -> *(SpecialSubstitution,(*TypeHeaps,u:OpenTypeSymbols,*CheckState))
check_environment mod_index env (heaps, ots, cs)
# oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(env, (ots, {oti_heaps,oti_all_vars,oti_all_attrs,oti_global_vars}, cs)) = mapSt (check_substituted_type mod_index) env (ots, oti, cs)
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table
cs = check_no_global_type_vars oti_global_vars {cs & cs_symbol_table = cs_symbol_table}
= ({ ss_environ = env, ss_context = [], ss_vars = oti_all_vars, ss_attrs = oti_all_attrs}, (oti_heaps, ots, cs))
where
check_substituted_type mod_index bind=:{bind_src} cot_state
# (bind_src, cot_state) = checkOpenType mod_index cGlobalScope DAK_Ignore bind_src cot_state
= ({ bind & bind_src = bind_src }, cot_state)
checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
/* cOuterMostLevel :== 0 */
......
......@@ -491,19 +491,19 @@ where
# (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState
(tspec, pState) = want pState // SymbolType
| isDclContext parseContext
# (specials, pState) = optionalSpecials pState
# (specials, pState) = optionalFunSpecials pState
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
want_rhs_of_def parseContext (opt_name, args) (PriorityToken prio) pos pState
# (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState
(token, pState) = nextToken TypeContext pState
| token == DoubleColonToken
# (tspec, pState) = want pState
| isDclContext parseContext
# (specials, pState) = optionalSpecials pState
# (specials, pState) = optionalFunSpecials pState
= (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type definition" (tokenBack pState))
= (PD_TypeSpec pos name prio (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name prio No FSP_None, wantEndOfDefinition "type definition" (tokenBack pState))
want_rhs_of_def parseContext (No, args) token pos pState
# pState = want_node_def_token pState token
# (ss_useLayout, pState) = accScanState UseLayout pState
......@@ -690,12 +690,24 @@ optionalSpecials :: !ParseState -> (!Specials, !ParseState)
optionalSpecials pState
# (token, pState) = nextToken TypeContext pState
| token == SpecialToken
# (token, pState) = nextToken GeneralContext pState
pState = begin_special_group token pState
# (specials, pState) = wantList "<special statement>" try_substitutions pState
= (SP_ParsedSubstitutions specials, end_special_group pState)
// otherwise // token <> SpecialToken
# (specials, pState) = wantSpecials pState
= (SP_ParsedSubstitutions specials, pState)
= (SP_None, tokenBack pState)
optionalFunSpecials :: !ParseState -> (!FunSpecials, !ParseState)
optionalFunSpecials pState
# (token, pState) = nextToken TypeContext pState
| token == SpecialToken
# (specials, pState) = wantSpecials pState
= (FSP_ParsedSubstitutions specials, pState)
= (FSP_None, tokenBack pState)
wantSpecials :: !ParseState -> (![Env Type TypeVar], !ParseState)
wantSpecials pState
# (token, pState) = nextToken GeneralContext pState
pState = begin_special_group token pState
(specials, pState) = wantList "<special statement>" try_substitutions pState
= (specials, end_special_group pState)
where
try_substitutions pState
# (succ, type_var, pState) = tryTypeVar pState
......@@ -1303,7 +1315,7 @@ wantClassDefinition parseContext pos pState
# (tspec, pState) = want pState
(member_id, pState) = stringToIdent member_name IC_Expression pState
(class_id, pState) = stringToIdent member_name IC_Class pState
member = PD_TypeSpec pos member_id prio (Yes tspec) SP_None
member = PD_TypeSpec pos member_id prio (Yes tspec) FSP_None
class_def = { class_ident = class_id, class_arity = class_arity, class_args = class_args,
class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars,
class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }
......
......@@ -499,13 +499,12 @@ where
= ([tc_class_def], [tc_member_def])
// MW..
make_identity_fun_type alias_dummy_id type_var
# a = { at_attribute = TA_Anonymous, at_type = TV type_var }
id_symbol_type = { st_vars = [], st_args = [a], st_args_strictness = Strict 1, st_arity = 1, st_result = a, st_context = [],
st_attr_vars = [], st_attr_env = [] } // !.a -> .a
= { ft_ident = alias_dummy_id, ft_arity = 1, ft_priority = NoPrio, ft_type = id_symbol_type, ft_pos = NoPos,
ft_specials = SP_None, ft_type_ptr = nilPtr }
ft_specials = FSP_None, ft_type_ptr = nilPtr }
DynamicRepresentation_String :== "DynamicTemp" // "_DynamicTemp"
......
......@@ -257,7 +257,7 @@ cIsNotAFunction :== False
= PD_Function Position Ident Bool [ParsedExpr] Rhs FunKind
| PD_NodeDef Position ParsedExpr Rhs
| PD_Type ParsedTypeDef
| PD_TypeSpec Position Ident Priority (Optional SymbolType) Specials
| PD_TypeSpec Position Ident Priority (Optional SymbolType) FunSpecials
| PD_Class ClassDef [ParsedDefinition]
| PD_Instance (ParsedInstance ParsedDefinition)
| PD_Instances [ParsedInstance ParsedDefinition]
......@@ -310,7 +310,7 @@ cNameLocationDependent :== True
These can only occur in definition modules. After parsing the SP_ParsedSubstitutions alternative
is used to indicate the specific instantiation. The SP_Substitutions alternative is used to deduce
the type of the specialized version. Finally the SP_ContextTypes alternative is set and used during
the typing to check whether this instance has been used. The auxiliary SP_FunIndex alternative is used
the typing to check whether this instance has been used. The auxiliary FSP_FunIndex alternative is used
to store the index of the function that has been specialized.
*/
......@@ -318,10 +318,16 @@ cNameLocationDependent :== True
= SP_ParsedSubstitutions ![Env Type TypeVar]
| SP_Substitutions ![SpecialSubstitution]
| SP_ContextTypes ![Special]
| SP_FunIndex !Index
| SP_TypeOffset !Int
| SP_TypeOffset !Int // index in SP_Substitutions for specialized instance
| SP_None
:: FunSpecials
= FSP_ParsedSubstitutions ![Env Type TypeVar]
| FSP_Substitutions ![SpecialSubstitution]
| FSP_ContextTypes ![Special]
| FSP_FunIndex !Index
| FSP_None
:: SpecialSubstitution =
{ ss_environ :: !Env Type TypeVar
, ss_context :: ![TypeContext]
......@@ -572,7 +578,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
, ft_priority :: !Priority
, ft_type :: !SymbolType
, ft_pos :: !Position
, ft_specials :: !Specials
, ft_specials :: !FunSpecials
, ft_type_ptr :: !VarInfoPtr
}
......
......@@ -2958,8 +2958,8 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
// Check imported overloaded function application for specials...
# {ft_specials} = ro.ro_imported_funs.[glob_module].[glob_object]
# specials = case ft_specials of
(SP_ContextTypes s) -> s
_ -> []
FSP_ContextTypes s -> s
_ -> []
| not (isEmpty specials)
# (ei,ti_symbol_heap) = mapSt readAppInfo app_args ti.ti_symbol_heap
with
......@@ -4551,7 +4551,6 @@ where
(SP_ParsedSubstitutions _) -> file <<< "SP_ParsedSubstitutions"
(SP_Substitutions _) -> file <<< "SP_Substitutions"
(SP_ContextTypes l) -> file <<< "(SP_ContextTypes: " <<< l <<< ")"
(SP_FunIndex i) -> file <<< "(SP_FunIndex: " <<< i <<< ")"
(SP_TypeOffset _) -> file <<< "SP_TypeOffset"
SP_None -> file <<< "SP_None"
......
......@@ -1259,8 +1259,8 @@ getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_k
# (fun_type_copy, ts) = determineSymbolTypeOfFunction pos symb_ident n_app_args ft_type ft_type_ptr ti_common_defs ts
= (fun_type_copy, get_specials ft_specials, ts)
where
get_specials (SP_ContextTypes specials) = specials
get_specials SP_None = []
get_specials (FSP_ContextTypes specials) = specials
get_specials FSP_None = []
getSymbolType pos ti {symb_kind = SK_Constructor {glob_module,glob_object}} n_app_args ts
# (fresh_cons_type, ts) = standardRhsConstructorType pos glob_object glob_module n_app_args ti ts
= (fresh_cons_type, [], ts)
......
......@@ -44,7 +44,7 @@ instance makeTypeFun FunType where
, ft_priority = NoPrio
, ft_type = symbol_type
, ft_pos = position
, ft_specials = SP_None
, ft_specials = FSP_None
, ft_type_ptr = ft_type_ptr
}, var_heap, symbol_table)
......
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