Commit a832f863 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

renamed field names of type Ident in syntax tree

s/\<mod_name\>/mod_ident/g
s/\<ps_field_name\>/ps_field_ident/g
s/\<ps_selector_name\>/ps_selector_ident/g
s/\<pc_cons_name\>/pc_cons_ident/g
s/\<class_name\>/class_ident/g
s/\<gen_name\>/gen_ident/g
s/\<gen_member_name\>/gen_member_ident/g
s/\<gc_name\>/gc_ident/g
s/\<gc_gname\>/gc_gident/g
s/\<fs_name\>/fs_ident/g
s/\<td_name\>/td_ident/g
s/\<fv_name\>/fv_ident/g
s/\<var_name\>/var_ident/g
s/\<type_name\>/type_ident/g
s/\<symb_name\>/symb_ident/g
s/\<tv_name\>/tv_ident/g
s/\<av_name\>/av_ident/g
s/\<me_symb\>/me_ident/g
s/\<ft_symb\>/ft_ident/g
s/\<fun_symb\>/fun_ident/g
s/\<cons_symb\>/cons_ident/g
s/\<sd_symb\>/sd__ident/g
parent c86de72d
......@@ -414,17 +414,17 @@ backEndConvertModulesH predefs {fe_icl =
( "dcl conversions"
, currentDcl.dcl_conversions
, "dcl constructors"
, [constructor.cons_symb.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
, [constructor.cons_ident.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
, "dcl selectors"
, [selector.sd_symb.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
, [selector.sd__ident.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
, "dcl types"
, [type.td_name.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
, [type.td_ident.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
, "icl constructors"
, [constructor.cons_symb.id_name \\ constructor <-: icl_common.com_cons_defs]
, [constructor.cons_ident.id_name \\ constructor <-: icl_common.com_cons_defs]
, "icl selectors"
, [selector.sd_symb.id_name \\ selector <-: icl_common.com_selector_defs]
, [selector.sd__ident.id_name \\ selector <-: icl_common.com_selector_defs]
, "icl types"
, [type.td_name.id_name \\ type <-: icl_common.com_type_defs]
, [type.td_ident.id_name \\ type <-: icl_common.com_type_defs]
)
*/
#! backEnd
......@@ -539,7 +539,7 @@ where
= foldStateWithIndexA (removeExpandedTypesFromFunType moduleIndex) dcl_functions
where
removeExpandedTypesFromFunType :: ModuleIndex Index FunType -> BackEnder
removeExpandedTypesFromFunType moduleIndex functionIndex {ft_symb, ft_type_ptr}
removeExpandedTypesFromFunType moduleIndex functionIndex {ft_ident, ft_type_ptr}
= \be0 -> let (ft_type,be) = read_from_var_heap ft_type_ptr be0 in
(case ft_type of
VI_ExpandedType expandedType
......@@ -563,16 +563,16 @@ instance declareVars (Ptr VarInfo) where
instance declareVars FreeVar where
declareVars :: FreeVar !DeclVarsInput -> BackEnder
declareVars freeVar _
= declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
= declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
instance declareVars LetBind where
declareVars :: LetBind !DeclVarsInput -> BackEnder
declareVars {lb_src=App {app_symb, app_args=[Var _:_]}, lb_dst=freeVar} aliasDummyId
| not (isNilPtr app_symb.symb_name.id_info) && app_symb.symb_name==aliasDummyId
| not (isNilPtr app_symb.symb_ident.id_info) && app_symb.symb_ident==aliasDummyId
= identity // we have an alias. Don't declare the same variable twice
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
declareVars {lb_dst=freeVar} _
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
declareVariable :: Int (Ptr VarInfo) {#Char} -> BackEnder
declareVariable lhsOrRhs varInfoPtr name
......@@ -614,7 +614,7 @@ instance declareVars Expression where
= foldState declVar outParams
where
declVar {bind_dst=freeVar}
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name
= declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_ident.id_name
declareVars _ _
= identity
......@@ -666,7 +666,7 @@ declareFunctionSymbols functions functionIndices globalFunctions backEnd
= foldl declare backEnd [(functionIndex, componentIndex, functions.[functionIndex]) \\ (componentIndex, functionIndex) <- functionIndices]
where
declare backEnd (functionIndex, componentIndex, function)
= appBackEnd (BEDeclareFunction (functionName function.fun_symb.id_name functionIndex globalFunctions)
= appBackEnd (BEDeclareFunction (functionName function.fun_ident.id_name functionIndex globalFunctions)
function.fun_arity functionIndex componentIndex) backEnd
where
functionName :: {#Char} Int [IndexRange] -> {#Char}
......@@ -720,7 +720,7 @@ declareArrayInstances array_first_instance_indices /*{ir_from, ir_to}*/ predefs
= declareArrayInstances (member_n+1) first_member_index backend
declareArrayInstance :: Index FunDef -> BackEnder
declareArrayInstance index {fun_symb={id_name}, fun_type=Yes type}
declareArrayInstance index {fun_ident={id_name}, fun_type=Yes type}
= beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
o` beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type)
......@@ -745,7 +745,7 @@ declareListInstances array_first_instance_indices predef_list_class_index predef
= declareListInstances (member_n+1) first_member_index backend
declareListInstance :: Index FunDef -> BackEnder
declareListInstance index {fun_symb={id_name}, fun_type=Yes type}
declareListInstance index {fun_ident={id_name}, fun_type=Yes type}
// | trace_tn ("declareListInstance "+++toString index+++" "+++toString main_dcl_module_n)
= beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
o` beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type)
......@@ -758,20 +758,20 @@ instance declare CommonDefs where
instance declareWithIndex (TypeDef a) where
declareWithIndex :: Index ModuleIndex (TypeDef a) -> BackEnder
declareWithIndex typeIndex moduleIndex {td_name}
= appBackEnd (BEDeclareType typeIndex moduleIndex td_name.id_name)
declareWithIndex typeIndex moduleIndex {td_ident}
= appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name)
declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder
declareFunTypes moduleIndex funTypes nrOfDclFunctions
= foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes
declareFunType :: ModuleIndex Index Int FunType -> BackEnder
declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_ident, ft_type_ptr}
= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
(case vi of
VI_ExpandedType expandedType
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_symb.id_name functionIndex nrOfDclFunctions)
// -> beDeclareRuleType functionIndex moduleIndex (functionName moduleIndex ft_symb.id_name functionIndex nrOfDclFunctions)
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex nrOfDclFunctions)
// -> beDeclareRuleType functionIndex moduleIndex (functionName moduleIndex ft_ident.id_name functionIndex nrOfDclFunctions)
o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
_
-> identity) be
......@@ -809,17 +809,17 @@ convertTypeVars typeVars
convertTypeVar :: ATypeVar -> BEMonad BETypeVarListP
convertTypeVar typeVar
= beTypeVarListElem (beTypeVar typeVar.atv_variable.tv_name.id_name) (convertAttribution typeVar.atv_attribute)
= beTypeVarListElem (beTypeVar typeVar.atv_variable.tv_ident.id_name) (convertAttribution typeVar.atv_attribute)
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
defineType moduleIndex constructors _ typeIndex {td_name, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (constructors, be)
= convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEAlgebraicType flatType constructors) be
defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}} be
// | trace_tn constructorDef.cons_symb
// | trace_tn constructorDef.cons_ident
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (fields, be)
......@@ -858,7 +858,7 @@ convertConstructors typeIndex typeName moduleIndex constructors symbols
convertConstructor :: Int {#Char} ModuleIndex {#ConsDef} DefinedSymbol -> BEMonad BEConstructorListP
convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
= \be0 -> let (constructorType,be) = constructorTypeFunction be0 in
(appBackEnd (BEDeclareConstructor ds_index moduleIndex constructorDef.cons_symb.id_name) // +++ remove declare
(appBackEnd (BEDeclareConstructor ds_index moduleIndex constructorDef.cons_ident.id_name) // +++ remove declare
o` beConstructor
(beNormalTypeNode
(beConstructorSymbol moduleIndex ds_index)
......@@ -870,9 +870,9 @@ convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
= let (cons_type,be) = read_from_var_heap constructorDef.cons_type_ptr be0 in
(case cons_type of
VI_ExpandedType expandedType
-> (expandedType,be) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, expandedType)
-> (expandedType,be) // ->> (typeName, typeIndex, constructorDef.cons_ident.id_name, ds_index, expandedType)
_
-> (constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
-> (constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_ident.id_name, ds_index, constructorDef.cons_type)
foldrAi function result array
......@@ -897,7 +897,7 @@ convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFiel
//convertSelector moduleIndex selectorDefs {fs_index}
convertSelector moduleIndex selectorDefs is_strict {fs_index}
= \be0 -> let (selectorType,be) = selectorTypeFunction be0 in
( appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd_symb.id_name)
( appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd__ident.id_name)
// o` beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
o` beField fs_index moduleIndex (convertAnnotAndTypeNode (if is_strict AN_Strict AN_None) (selectorType.st_result))) be
where
......@@ -1253,10 +1253,10 @@ convertRules rules main_dcl_module_n aliasDummyId be
= convert t rulesP be
convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb, fun_info}) main_dcl_module_n
// | trace_tn fun_symb.id_name
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_ident, fun_info}) main_dcl_module_n
// | trace_tn fun_ident.id_name
= beRule index (cafness fun_kind)
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type, (fun_info.fi_group_index, body))))
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_ident.id_name, index, type, (fun_info.fi_group_index, body))))
(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
where
cafness :: FunKind -> Int
......@@ -1376,7 +1376,7 @@ nextAttributeNumber state=:{bes_attr_number}
= (bes_attr_number + BEFirstUniVarNumber, {state & bes_attr_number = bes_attr_number+1})
convertAttributeVar :: AttributeVar *BackEndState -> (BEAttribution, *BackEndState)
convertAttributeVar {av_info_ptr, av_name} state=:{bes_attr_number}
convertAttributeVar {av_info_ptr, av_ident} state=:{bes_attr_number}
# (attrInfo, state)
= read_from_attr_heap av_info_ptr state
= case attrInfo of
......@@ -1447,8 +1447,8 @@ convertTypeNode (TA typeSymbolIdent typeArgs)
convertTypeNode (TAS typeSymbolIdent typeArgs strictness)
// = beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertAnnotatedTypeArgs typeArgs strictness)
convertTypeNode (TV {tv_name})
= beVarTypeNode tv_name.id_name
convertTypeNode (TV {tv_ident})
= beVarTypeNode tv_ident.id_name
convertTypeNode (TempQV n)
= beVarTypeNode ("_tqv" +++ toString n)
convertTypeNode (TempV n)
......@@ -1746,7 +1746,7 @@ collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds})
filterStrictAlias [] let_lazy_binds
= let_lazy_binds
filterStrictAlias [strict_bind=:{lb_src=App app}:strict_binds] let_lazy_binds
| not (isNilPtr app.app_symb.symb_name.id_info) && app.app_symb.symb_name==aliasDummyId
| not (isNilPtr app.app_symb.symb_ident.id_info) && app.app_symb.symb_ident==aliasDummyId
// the compiled source was a strict alias like "#! x = y"
= case hd app.app_args of
Var _
......
......@@ -96,14 +96,14 @@ printFunctionTypes all attr info components functions attrHeap file backEnd
= flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: components & componentIndex <- [1..]]
printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap, *File, *BackEnd) -> (*AttrVarHeap, *File, *BackEnd)
printFunctionType all attr info (functionIndex, {fun_symb,fun_type=Yes type}) (attrHeap, file, backEnd)
printFunctionType all attr info (functionIndex, {fun_ident,fun_type=Yes type}) (attrHeap, file, backEnd)
| not all && functionIndex >= size info.dtic_dclModules.[info.dtci_iclModuleIndex].dcl_functions
= (attrHeap, file, backEnd)
// | trace_tn (toString fun_symb) && True ---> type.st_args
// | trace_tn (toString fun_ident) && True ---> type.st_args
# (strictnessAdded, type, backEnd)
= addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
= addStrictnessFromBackEnd functionIndex fun_ident.id_name backEnd type
| not strictnessAdded && not all
= (attrHeap, file, backEnd)
// FIXME: shouldn't have to repair the invariant here
......@@ -114,7 +114,7 @@ printFunctionType all attr info (functionIndex, {fun_symb,fun_type=Yes type}) (a
# (type, attrHeap)
= beautifulizeAttributes type attrHeap
# file
= file <<< fun_symb <<< " :: "
= file <<< fun_ident <<< " :: "
<:: ({ form_properties = (if attr cAttributed 0) bitor cAnnotated, form_attr_position = No }, type, Yes initialTypeVarBeautifulizer) <<< '\n'
= (attrHeap, file, backEnd)
......@@ -388,10 +388,10 @@ where
= {tc_class = TCClass klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}
typeToClass info {type_ident, type_arity, type_index={glob_module, glob_object}}
= case typeIndexToClassIndex info glob_module glob_object of
Yes classIndex
-> Yes {glob_module=glob_module, glob_object = {ds_ident = type_name, ds_arity = type_arity, ds_index = glob_object}}
-> Yes {glob_module=glob_module, glob_object = {ds_ident = type_ident, ds_arity = type_arity, ds_index = glob_object}}
No
-> No
where
......
......@@ -164,8 +164,8 @@ instance sequence LetBind where
= sequence` app lb_dst
where
sequence` {app_symb, app_args} lb_dst sequenceState=:{ss_aliasDummyId}
| not (isNilPtr app_symb.symb_name.id_info) // nilPtr's are generated for Case's with case_ident=No in convertcases
&& app_symb.symb_name==ss_aliasDummyId
| not (isNilPtr app_symb.symb_ident.id_info) // nilPtr's are generated for Case's with case_ident=No in convertcases
&& app_symb.symb_ident==ss_aliasDummyId
// the compiled source was a strict alias like "#! x = y"
= case hd app_args of
Var bound_var=:{var_info_ptr}
......
......@@ -224,12 +224,12 @@ where
instance =< BoundVar
where
(=<) bv1 bv2
= bv1.var_name =< bv2.var_name
= bv1.var_ident =< bv2.var_ident
instance =< FreeVar
where
(=<) fv1 fv2
= fv1.fv_name =< fv2.fv_name
= fv1.fv_ident =< fv2.fv_ident
instance =< Ident
where
......@@ -244,7 +244,7 @@ where
instance =< TypeSymbIdent
where
(=<) s1 s2
= s1.type_name =< s2.type_name
= s1.type_ident =< s2.type_ident
instance =< Type
where
......@@ -316,5 +316,5 @@ where
instance < MemberDef
where
(<) md1 md2 = md1.me_symb.id_name < md2.me_symb.id_name
(<) md1 md2 = md1.me_ident.id_name < md2.me_ident.id_name
......@@ -96,7 +96,7 @@ where
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td.td_name td.td_pos) type td_attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td.td_ident td.td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
# type_defs = { type_defs & [gi_module, gi_index] = { td & td_rhs = SynType type}}
......@@ -120,18 +120,18 @@ where
# (ok, subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps
| ok
-> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error)
# error = popErrorAdmin (typeSynonymError used_td.td_name "kind conflict in argument of type synonym" (pushErrorAdmin pos error))
# error = popErrorAdmin (typeSynonymError used_td.td_ident "kind conflict in argument of type synonym" (pushErrorAdmin pos error))
-> (No, type_defs, type_heaps, error)
_
-> (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
| main_dcl_module_index == main_dcl_module_index && gi_index < size main_dcl_type_defs
# (td=:{td_rhs,td_attribute,td_name,td_pos}, main_dcl_type_defs) = main_dcl_type_defs![gi_index]
# (td=:{td_rhs,td_attribute,td_ident,td_pos}, main_dcl_type_defs) = main_dcl_type_defs![gi_index]
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td_name td_pos) type td_attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td_ident td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
-> (type_defs, { main_dcl_type_defs & [gi_index] = { td & td_rhs = SynType type}}, type_heaps, error)
......@@ -158,7 +158,7 @@ where
partitionateTypeDef gi=:{gi_module,gi_index} pi=:{pi_type_defs}
# ({td_name,td_pos,td_used_types}, pi) = pi!pi_type_defs.[gi_module].[gi_index]
# ({td_ident,td_pos,td_used_types}, pi) = pi!pi_type_defs.[gi_module].[gi_index]
pi = push_on_dep_stack gi pi
(min_dep, pi) = foldSt visit_type td_used_types (cMAXINT, pi)
= try_to_close_group gi min_dep pi
......@@ -195,13 +195,13 @@ where
where
check_cyclic_type_def td=:{gi_module,gi_index} (group, marks, typedefs, error)
# (mark, marks) = marks![gi_module,gi_index]
# ({td_name,td_pos,td_used_types,td_rhs}, typedefs) = typedefs![gi_module].[gi_index]
# ({td_ident,td_pos,td_used_types,td_rhs}, typedefs) = typedefs![gi_module].[gi_index]
| mark == cChecking
= (group, marks, typedefs, typeSynonymError td_name "cyclic dependency between type synonyms" error)
= (group, marks, typedefs, typeSynonymError td_ident "cyclic dependency between type synonyms" error)
| mark < cMAXINT
| is_synonym_type td_rhs
# marks = { marks & [gi_module,gi_index] = cChecking }
error = pushErrorAdmin (newPosition td_name td_pos) error
error = pushErrorAdmin (newPosition td_ident td_pos) error
(group, marks, typedefs, error) = check_cyclic_type_defs td_used_types [td : group] marks typedefs error
error = popErrorAdmin error
= (group, { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error)
......@@ -373,8 +373,8 @@ where
analTypes_for_TA :: Ident Int Int Int [AType] !Bool !{#CommonDefs} ![KindInfoPtr] !Conditions !*AnalyseState
-> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalyseState))
analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
# {td_arity, td_name} = modules.[glob_module].com_type_defs.[glob_object]
analTypes_for_TA type_ident glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
# {td_arity, td_ident} = modules.[glob_module].com_type_defs.[glob_object]
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
| type_arity <= td_arity
# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
......@@ -384,8 +384,8 @@ analTypes_for_TA type_name glob_module glob_object type_arity types has_root_att
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
new_properties = condCombineTypeProperties has_root_attr type_properties tdi_properties
= (kind, new_properties, conds_as)
// ---> ("analTypes_for_TA", td_name, type_properties, tdi_properties, new_properties, has_root_attr)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
// ---> ("analTypes_for_TA", td_ident, type_properties, tdi_properties, new_properties, has_root_attr)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_ident type_appl_error as.as_error }))
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
......@@ -421,10 +421,10 @@ instance analTypes Type
where
analTypes has_root_attr modules form_tvs (TV tv) conds_as
= analTypes has_root_attr modules form_tvs tv conds_as
analTypes has_root_attr modules form_tvs type=:(TA {type_name,type_index={glob_module,glob_object},type_arity} types) (conds, as)
= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs type=:(TAS {type_name,type_index={glob_module,glob_object},type_arity} types _) (conds, as)
= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs type=:(TA {type_ident,type_index={glob_module,glob_object},type_arity} types) (conds, as)
= analTypes_for_TA type_ident glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs type=:(TAS {type_ident,type_index={glob_module,glob_object},type_arity} types _) (conds, as)
= analTypes_for_TA type_ident glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as
# (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
(res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
......@@ -582,8 +582,8 @@ where
anal_type_def modules gi=:{gi_module,gi_index} (group_properties, conds, as=:{as_error})
# {com_type_defs,com_cons_defs} = modules.[gi_module]
{td_name,td_pos,td_args,td_rhs} = com_type_defs.[gi_index]
as_error = pushErrorAdmin (newPosition td_name td_pos) as_error
{td_ident,td_pos,td_args,td_rhs} = com_type_defs.[gi_index]
as_error = pushErrorAdmin (newPosition td_ident td_pos) as_error
(type_properties, (conds, as)) = anal_rhs_of_type_def modules com_cons_defs td_rhs (conds, { as & as_error = as_error })
= (combineTypeProperties group_properties type_properties, conds, {as & as_error = popErrorAdmin as.as_error })
where
......@@ -654,8 +654,8 @@ where
update_type_def_info modules type_properties top_vars {gi_module,gi_index} updated_kinds
(kind_store, kind_heap, td_infos)
// # {com_type_defs} = modules.[gi_module]
// {td_name} = com_type_defs.[gi_index]
# (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] // ---> ("update_type_def_info", td_name, type_properties)
// {td_ident} = com_type_defs.[gi_index]
# (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] // ---> ("update_type_def_info", td_ident, type_properties)
# (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds updated_kinds top_vars kind_store kind_heap
= (kind_store, kind_heap, { td_infos & [gi_module,gi_index] =
{td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars }})
......@@ -681,12 +681,12 @@ where
check_dcl_properties modules dcl_types dcl_mod_index properties {gi_module, gi_index} as
| gi_module == dcl_mod_index && gi_index < size dcl_types
# {td_name, td_rhs, td_args, td_pos} = dcl_types.[gi_index]
# {td_ident, td_rhs, td_args, td_pos} = dcl_types.[gi_index]
= case td_rhs of
AbstractType spec_properties
# as_error = pushErrorAdmin (newPosition td_name td_pos) as.as_error
# as_error = pushErrorAdmin (newPosition td_ident td_pos) as.as_error
| check_coercibility spec_properties properties
// ---> ("check_coercibility", td_name, spec_properties, properties)
// ---> ("check_coercibility", td_ident, spec_properties, properties)
|check_hyperstrictness spec_properties properties
| spec_properties bitand cIsNonCoercible == 0
# (as_type_var_heap, as_td_infos, as_error) = check_positive_sign gi_module gi_index modules td_args as.as_type_var_heap as.as_td_infos as_error
......@@ -793,10 +793,10 @@ where
determine_kinds_of_class modules class_module class_index (class_infos, as)
| isEmpty class_infos.[class_module,class_index]
# {com_class_defs,com_member_defs} = modules.[class_module]
{class_args,class_context,class_members,class_arity,class_pos,class_name} = com_class_defs.[class_index]
{class_args,class_context,class_members,class_arity,class_pos,class_ident} = com_class_defs.[class_index]
(class_kind_vars, as_kind_heap) = fresh_kind_vars class_arity [] as.as_kind_heap
as_type_var_heap = bind_kind_vars class_args class_kind_vars as.as_type_var_heap
as_error = pushErrorAdmin (newPosition class_name class_pos) as.as_error
as_error = pushErrorAdmin (newPosition class_ident class_pos) as.as_error
class_infos = { class_infos & [class_module,class_index] = cyclicClassInfoMark }
(class_infos, as) = determine_kinds_of_context_classes class_context (class_infos,
{ as & as_kind_heap = as_kind_heap, as_type_var_heap = as_type_var_heap, as_error = as_error })
......@@ -805,12 +805,12 @@ where
(class_infos, as) = determine_kinds_of_members modules class_members com_member_defs class_kind_vars (class_infos, as)
(class_kinds, as_kind_heap) = retrieve_class_kinds class_kind_vars as.as_kind_heap
= ({class_infos & [class_module,class_index] = class_kinds }, { as & as_kind_heap = as_kind_heap, as_error = popErrorAdmin as.as_error})
// ---> ("determine_kinds_of_class", class_name, class_kinds)
// ---> ("determine_kinds_of_class", class_ident, class_kinds)
= ({class_infos & [class_module,class_index] = [ KindConst \\ _ <- [1..class_arity]] }, { as & as_error = popErrorAdmin as.as_error })
| isCyclicClass class_infos.[class_module,class_index]
# {class_name,class_arity} = modules.[class_module].com_class_defs.[class_index]
# {class_ident,class_arity} = modules.[class_module].com_class_defs.[class_index]
= ({ class_infos & [class_module,class_index] = [ KindConst \\ _ <- [1..class_arity]]},
{ as & as_error = checkError class_name class_def_error as.as_error })
{ as & as_error = checkError class_ident class_def_error as.as_error })
= (class_infos, as)
where
fresh_kind_vars nr_of_vars fresh_vars kind_heap
......@@ -948,8 +948,8 @@ where
= check_kinds_of_generics common_defs (inc index) generic_defs class_infos gen_heap as
where
check_kinds_of_generic :: !{#CommonDefs} !GenericDef !*ClassDefInfos !*GenericHeap !*AnalyseState -> (!*ClassDefInfos, !*GenericHeap, !*AnalyseState)
check_kinds_of_generic common_defs {gen_type, gen_name, gen_pos, gen_vars, gen_info_ptr} class_infos gen_heap as
# as = {as & as_error = pushErrorAdmin (newPosition gen_name gen_pos) as.as_error}
check_kinds_of_generic common_defs {gen_type, gen_ident, gen_pos, gen_vars, gen_info_ptr} class_infos gen_heap as
# as = {as & as_error = pushErrorAdmin (newPosition gen_ident gen_pos) as.as_error}
# (class_infos, as) = check_kinds_of_symbol_type common_defs gen_type class_infos as
# (kinds, as) = mapSt retrieve_tv_kind gen_type.st_vars as
# as = check_kinds_of_generic_vars (take (length gen_vars) kinds) as
......@@ -998,11 +998,11 @@ where
= as
check_kinds_of_icl_fuction common_defs fun_index (icl_fun_defs, class_infos, expression_heap, as)
# ({fun_type,fun_symb,fun_info,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index]
# ({fun_type,fun_ident,fun_info,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index]
(expression_heap, as) = check_kinds_of_dynamics common_defs fun_info.fi_dynamics expression_heap as
= case fun_type of
Yes symbol_type
# as_error = pushErrorAdmin (newPosition fun_symb fun_pos) as.as_error
# as_error = pushErrorAdmin (newPosition fun_ident fun_pos) as.as_error
(class_infos, as) = check_kinds_of_symbol_type common_defs symbol_type class_infos { as & as_error = as_error }
-> (icl_fun_defs, class_infos, expression_heap, { as & as_error = popErrorAdmin as.as_error })
No
......@@ -1015,8 +1015,8 @@ where
= (dcl_modules, class_infos, as)
where
check_kinds_of_dcl_fuction common_defs dcl_functions fun_index (class_infos, as)
# {ft_type,ft_symb,ft_pos} = dcl_functions.[fun_index]
as_error = pushErrorAdmin (newPosition ft_symb ft_pos) as.as_error
# {ft_type,ft_ident,ft_pos} = dcl_functions.[fun_index]
as_error = pushErrorAdmin (newPosition ft_ident ft_pos) as.as_error
(class_infos, as) = check_kinds_of_symbol_type common_defs ft_type class_infos
{ as & as_error = as_error }
= (class_infos, { as & as_error = popErrorAdmin as.as_error})
......@@ -1073,13 +1073,13 @@ where
checkLeftRootAttributionOfTypeDef :: !{# CommonDefs} GlobalIndex !(!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
-> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
checkLeftRootAttributionOfTypeDef common_defs {gi_module,gi_index} (td_infos, th_vars, error)
# {td_rhs, td_attribute, td_name, td_pos} = common_defs.[gi_module].com_type_defs.[gi_index]
# {td_rhs, td_attribute, td_ident, td_pos} = common_defs.[gi_module].com_type_defs.[gi_index]
| isUniqueAttr td_attribute
= (td_infos, th_vars, error)
# (is_unique, (td_infos, th_vars))
= isUniqueTypeRhs common_defs gi_module td_rhs (td_infos, th_vars)
| is_unique
= (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_name td_pos)
= (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_ident td_pos)
" left root * attribute expected" error)
= (td_infos, th_vars, error)
......
......@@ -29,7 +29,7 @@ typeProperties type_index module_index hio_signs hio_props defs type_var_heap td
(tsp_propagation, type_var_heap, td_infos) = determinePropClassOfTypeDef type_index module_index td_info hio_props defs type_var_heap td_infos
tsp_coercible = (td_info.tdi_properties bitand cIsNonCoercible) == 0
= ({tsp_sign = tsp_sign, tsp_propagation = tsp_propagation, tsp_coercible = tsp_coercible }, type_var_heap, td_infos)
// ---> ("typeProperties", (defs.[module_index].com_type_defs.[type_index].td_name, type_index, module_index), tsp_sign, tsp_propagation)
// ---> ("typeProperties", (defs.[module_index].com_type_defs.[type_index].td_ident, type_index, module_index), tsp_sign, tsp_propagation)
signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos
-> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos)
......@@ -38,7 +38,7 @@ signClassification type_index module_index hio_signs defs type_var_heap td_infos
# (tsp_sign, type_var_heap, td_infos)
= determineSignClassOfTypeDef type_index module_index td_info hio_signs defs type_var_heap td_infos
= (tsp_sign, type_var_heap, td_infos)
// ---> ("signClassification", defs.[module_index].com_type_defs.[type_index].td_name, tsp_sign)
// ---> ("signClassification", defs.[module_index].com_type_defs.[type_index].td_ident, tsp_sign)
removeTopClasses [cv : cvs] [tc : tcs]
......@@ -131,8 +131,8 @@ where
where
collect_sign_class_of_type_def group_nr signs_of_group_vars ci {gi_module,gi_index} (sign_requirements, type_var_heap, td_infos)
# ({tdi_group_vars,tdi_kinds,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index]
{td_name,td_args,td_rhs} = ci.[gi_module].com_type_defs.[gi_index]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
{td_ident,td_args,td_rhs} = ci.[gi_module].com_type_defs.[gi_index]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_ident, tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
(rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap)
(sign_env, scs) = sign_class_of_type_def gi_module td_rhs group_nr ci
{scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] }
......@@ -222,7 +222,7 @@ IsArrowKind (KindArrow _) = True
IsArrowKind _ = False
signClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState)
signClassOfTypeVariable {tv_name,tv_info_ptr} ci scs=:{scs_type_var_heap}
signClassOfTypeVariable {tv_ident,tv_info_ptr} ci scs=:{scs_type_var_heap}
# (var_info, scs_type_var_heap) = readPtr tv_info_ptr scs_type_var_heap
scs = { scs & scs_type_var_heap = scs_type_var_heap }
= case var_info of
......@@ -243,7 +243,7 @@ signClassOfType_for_TA glob_module glob_object types sign use_top_sign group_nr
# (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object]
| tdi_group_nr == group_nr
= sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_index_in_group ci [] scs
# {td_arity,td_name} = ci.[glob_module].com_type_defs.[glob_object]
# {td_arity,td_ident} = ci.[glob_module].com_type_defs.[glob_object]
(sign_classes, hio_signs, scs) = collect_sign_classes_of_type_list types tdi_kinds group_nr ci scs
(type_class, scs_type_var_heap, scs_type_def_infos)
= determineSignClassOfTypeDef glob_object glob_module td_info hio_signs ci scs.scs_type_var_heap scs.scs_type_def_infos
......@@ -327,7 +327,7 @@ propClassification type_index module_index hio_props defs type_var_heap td_infos
# (tsp_prop, type_var_heap, td_infos)
= determinePropClassOfTypeDef type_index module_index td_info hio_props defs type_var_heap td_infos
= (tsp_prop, type_var_heap, td_infos)