Skip to content
GitLab
Commit 4a1404f8 authored by John van Groningen's avatar John van Groningen
Browse files

store strictness annotations in SymbolType instead of AType

parent 895ef836
Expand all Hide whitespace changes
Inline Side-by-side
backend/backendconvert.icl
View file @ 4a1404f8
......@@ -790,12 +790,14 @@ declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
functionName :: {#Char} Int Int -> {#Char}
functionName name functionIndex nrOfDclFunctions
// | trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))
| functionIndex < nrOfDclFunctions
= name
// otherwise
= name +++ ";" +++ toString functionIndex
import StdDebug
//import StdDebug
/*
declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} -> BackEnder
......@@ -824,10 +826,13 @@ defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgTyp
= convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEAlgebraicType flatType constructors) be
defineType moduleIndex constructors selectors typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
// | trace_tn constructorDef.cons_symb
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_args be
# (fields, be)
= convertSelectors moduleIndex selectors rt_fields be
// = convertSelectors moduleIndex selectors rt_fields be
= convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness be
# (constructorType,be) = constructorTypeFunction be
# (constructorTypeNode, be)
= beNormalTypeNode
......@@ -875,15 +880,32 @@ convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
_
-> (constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols
= foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
convertSelector moduleIndex selectorDefs {fs_index}
foldrAi function result array
:== foldrA 0
where
arraySize
= size array
foldrA index
| index == arraySize
= result
// otherwise
= function index array.[index] (foldrA (index+1))
//convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} StrictnessList -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols strictness
// = foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
= foldrAi (\i -> (beFields o convertSelector moduleIndex selectors (arg_is_strict i strictness))) beNoFields symbols
//convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFieldListP
//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)
o` beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
// 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
selectorDef
= selectorDefs.[fs_index]
......@@ -1238,6 +1260,7 @@ convertRules rules main_dcl_module_n aliasDummyId be
convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) main_dcl_module_n
// | trace_tn fun_symb.id_name
= beRule index (cafness fun_kind)
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type)))
(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
......@@ -1324,8 +1347,9 @@ convertAttributeKind attributeVar
= beAttributeKind (convertAttributeVar attributeVar)
convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
convertSymbolTypeArgs {st_args}
= convertTypeArgs st_args
convertSymbolTypeArgs {st_args,st_args_strictness}
// = convertTypeArgs st_args
= convertAnnotatedTypeArgs st_args st_args_strictness
convertBasicTypeKind :: BasicType -> BESymbKind
convertBasicTypeKind BT_Int
......@@ -1392,7 +1416,7 @@ convertAttribution attr
= abort "backendconvert, convertAttribution: unknown TypeAttribute" // <<- attr
convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
convertAnnotTypeNode {at_type, at_annotation, at_attribute}
convertAnnotTypeNode {at_type, at_attribute}
/*
= convertTypeNode at_type
:- beAnnotateTypeNode (convertAnnotation at_annotation)
......@@ -1404,6 +1428,15 @@ convertAnnotTypeNode {at_type, at_annotation, at_attribute}
:- beAnnotateTypeNode c_annot
:- beAttributeTypeNode c_attrib
// ) s
where
c_annot = convertAnnotation AN_None // at_annotation
c_attrib = convertAttribution at_attribute
convertAnnotAndTypeNode :: Annotation AType -> BEMonad BETypeNodeP
convertAnnotAndTypeNode at_annotation {at_type, at_attribute}
= convertTypeNode at_type
:- beAnnotateTypeNode c_annot
:- beAttributeTypeNode c_attrib
where
c_annot = convertAnnotation at_annotation
c_attrib = convertAttribution at_attribute
......@@ -1417,6 +1450,9 @@ convertTypeNode (TB basicType)
= beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs
convertTypeNode (TA typeSymbolIdent typeArgs)
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs 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 (TempQV n)
......@@ -1426,7 +1462,7 @@ convertTypeNode (TempV n)
convertTypeNode (a --> b)
= beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
convertTypeNode (a :@: b)
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_type = consVariableToType a} : b])
convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode (TFA vars type)
......@@ -1446,6 +1482,16 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP
convertTypeArgs args
= sfoldr (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args
convertAnnotatedTypeArgs :: [AType] StrictnessList -> BEMonad BETypeArgP
convertAnnotatedTypeArgs args strictness
= foldr args 0
where
foldr [] i
= beNoTypeArgs
foldr [a:x] i
// | trace_tn (toString i+++" "+++toString (arg_strictness_annotation i strictness))
= (beTypeArgs o (convertAnnotAndTypeNode (arg_strictness_annotation i strictness))) a (foldr x (i+1))
convertTransformedBody :: Int Int Ident TransformedBody Int -> BEMonad BERuleAltP
convertTransformedBody functionIndex lineNumber aliasDummyId body main_dcl_module_n
| isCodeBlock body.tb_rhs
......
backend/backendinterface.icl
View file @ 4a1404f8
......@@ -99,6 +99,9 @@ printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap
printFunctionType all attr info (functionIndex, {fun_symb,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
# (strictnessAdded, type, backEnd)
= addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
| not strictnessAdded && not all
......@@ -127,6 +130,9 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
= {si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName}
offset
= 0
// | trace_tn (toString bitSize+++" "+++toString strictPositions.[0])
# (robust, offset)
= nextBit strictnessInfo offset
strictnessInfo
......@@ -134,11 +140,19 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
# (anyStrictnessAdded, offset)
= nextBit strictnessInfo offset
# (type, offset)
= addStrictness strictnessInfo type offset
= addStrictnessToSymbolType strictnessInfo type offset
# type
= checkFinalOffset strictnessInfo offset type
= (anyStrictnessAdded, type, backEnd)
addStrictnessToSymbolType strictPositions=:{si_size} args offset
| offset >= si_size // short cut
= (args, offset)
addStrictnessToSymbolType strictPositions type=:{st_args,st_args_strictness} offset
# (st_args, offset,args_strictness)
= addStrictness strictPositions st_args offset st_args_strictness 0
= ({type & st_args = st_args,st_args_strictness=args_strictness}, offset)
:: StrictnessInfo =
{ si_size :: !Int
, si_positions :: !LargeBitvect
......@@ -146,7 +160,7 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
, si_robust_encoding :: !Bool
}
class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int)
class addStrictness a :: !StrictnessInfo !a Int StrictnessList Int -> (!a, !Int,!StrictnessList)
nextBit :: StrictnessInfo Int -> (Bool, Int)
nextBit {si_size, si_positions, si_robust_encoding} offset
......@@ -187,58 +201,64 @@ checkFinalOffset info=:{si_size, si_robust_encoding} offset value
// otherwise
= value
instance addStrictness SymbolType where
addStrictness strictPositions=:{si_size} args offset
| offset >= si_size // short cut
= (args, offset)
addStrictness strictPositions type=:{st_args} offset
# (st_args, offset)
= addStrictness strictPositions st_args offset
= ({type & st_args = st_args}, offset)
instance addStrictness [a] | addStrictness a where
addStrictness strictPositions l offset
= mapSt (addStrictness strictPositions) l offset
addStrictness strictPositions [] offset args_strictness args_strictness_index
= ([],offset,args_strictness)
addStrictness strictPositions [type:types] offset args_strictness args_strictness_index
# (type,offset,args_strictness)=addStrictness strictPositions type offset args_strictness args_strictness_index
# (types,offset,args_strictness)=addStrictness strictPositions types offset args_strictness (args_strictness_index+1)
= ([type:types],offset,args_strictness)
instance addStrictness AType where
addStrictness strictPositions arg=:{at_annotation, at_type} offset
# (at_annotation, offset)
= addStrictness strictPositions at_annotation offset
addStrictness strictPositions arg=:{at_type} offset args_strictness args_strictness_index
# (is_strict,offset,args_strictness)
= addStrictnessAnnotation strictPositions offset args_strictness args_strictness_index
# (at_type, offset)
= addStrictnessToType strictPositions (at_annotation == AN_Strict) at_type offset
= ({arg & at_annotation = at_annotation, at_type = at_type}, offset)
instance addStrictness Annotation where
addStrictness info annotation offset
# offset
= checkStrictness info wasStrict offset
# (strictAdded, offset)
= nextBit info offset
| strictAdded
| wasStrict
= addStrictnessToType strictPositions is_strict at_type offset
= ({arg & at_type=at_type}, offset,args_strictness)
addStrictnessAnnotation info offset args_strictness args_strictness_index
# wasStrict = arg_is_strict args_strictness_index args_strictness
# offset
= checkStrictness info wasStrict offset
# (strictAdded, offset)
= nextBit info offset
| strictAdded
| wasStrict
= abort "backendinterface, addStrictness: already strict"
// otherwise
= (AN_Strict, offset)
// otherwise
= (annotation, offset)
where
wasStrict
= annotation == AN_Strict
# args_strictness = add_strictness args_strictness_index args_strictness
= (True, offset,args_strictness)
// otherwise
= (wasStrict, offset,args_strictness)
addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int)
addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset
addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_index={glob_object,glob_module}} args) offset
# offset
= checkType strictPositions isTuple offset
| isTuple && isStrict
# (args, offset)
= addStrictness strictPositions args offset
= (TA ident args, offset)
# (args, offset,args_strictness)
= addStrictness strictPositions args offset NotStrict 0
| is_not_strict args_strictness
= (TA ident args, offset)
= (TAS ident args args_strictness, offset)
// otherwise
= (type, offset)
where
// FIXME: don't match on name but use predef info
isTuple
= type_name.id_name == "_Tuple" +++ toString type_arity
= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
addStrictnessToType strictPositions isStrict type=:(TAS ident=:{type_index={glob_object,glob_module}} args strictness) offset
# offset
= checkType strictPositions isTuple offset
| isTuple && isStrict
# (args, offset,strictness)
= addStrictness strictPositions args offset strictness 0
= (TAS ident args strictness, offset)
// otherwise
= (type, offset)
where
isTuple
= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
addStrictnessToType strictPositions _ type offset
# offset
= checkType strictPositions False offset
......@@ -274,6 +294,8 @@ instance collectAttrVars TypeAttribute where
instance collectAttrVars Type where
collectAttrVars (TA _ types) collect
= collectAttrVars types collect
collectAttrVars (TAS _ types _) collect
= collectAttrVars types collect
collectAttrVars (type1 --> type2) collect
= collectAttrVars type1 (collectAttrVars type2 collect)
collectAttrVars (TArrow1 type) collect
......@@ -316,28 +338,54 @@ DictionaryToClassInfo iclModuleIndex iclModule dclModules :==
}
dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType
dictionariesToClasses info type=:{st_args, st_arity, st_context=[]}
dictionariesToClasses info type=:{st_args, st_args_strictness, st_arity, st_context=[]}
# (reversedTypes, reversedContexts)
= dictionaryArgsToClasses info st_args ([], [])
# n_contexts = length reversedContexts
# new_st_args_strictness = remove_first_n_strictness_values n_contexts st_args_strictness
with
remove_first_n_strictness_values 0 s
= s
remove_first_n_strictness_values _ NotStrict
= NotStrict
remove_first_n_strictness_values n (Strict s)
| n<32
= Strict (((s>>1) bitand 0x7fffffff)>>(n-1))
= NotStrict
remove_first_n_strictness_values n (StrictList s l)
| n<32
# s2=case l of
Strict s -> s
StrictList s _ -> s
NotStrict -> 0
# s=(((s>>1) bitand 0x7fffffff)>>(n-1)) bitor (s2<<(32-n))
= StrictList s (remove_first_n_strictness_values n l)
= remove_first_n_strictness_values (n-32) l
= {type & st_args = reverse reversedTypes, st_context = reverse reversedContexts,
st_arity = st_arity - length reversedContexts}
st_arity = st_arity - n_contexts, st_args_strictness=new_st_args_strictness}
dictionaryArgsToClasses :: DictionaryToClassInfo [AType] ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgsToClasses info args result
= foldSt (dictionaryArgToClass info) args result
dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [context : reversedContexts])
with
context
= {tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass _ type (reversedTypes, reversedContexts)
= ([type : reversedTypes], reversedContexts)
where
dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [dictionary_to_context klass args : reversedContexts])
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass info type=:{at_type=TAS typeSymbol args _} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [dictionary_to_context klass args : reversedContexts])
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass _ type (reversedTypes, reversedContexts)
= ([type : reversedTypes], reversedContexts)
dictionary_to_context klass args
= {tc_class = 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}}
......
frontend/StdCompare.icl
View file @ 4a1404f8
......@@ -81,6 +81,12 @@ where
= arg_type1 == arg_type2 && restype1 == restype2
equal_constructor_args (TA tc1 types1) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TA tc1 types1) (TAS tc2 types2 _)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TAS tc2 types2 _)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TB tb1) (TB tb2)
= tb1 == tb2
equal_constructor_args (type1 :@: types1) (type2 :@: types2)
......@@ -236,6 +242,9 @@ where
where
compare_arguments (TB tb1) (TB tb2) = tb1 =< tb2
compare_arguments (TA tc1 _) (TA tc2 _) = tc1 =< tc2
compare_arguments (TA tc1 _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TA tc2 _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments _ _ = Equal
smallerOrEqual :: !Type !Type -> CompareValue
......@@ -251,6 +260,21 @@ smallerOrEqual t1 t2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TA tc1 args1) (TAS tc2 args2 _)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TA tc2 args2)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TAS tc2 args2 _)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (l1 --> r1) (l2 --> r2)
# cmp_app_symb = l1 =< l2
| cmp_app_symb==Equal
......
frontend/analtypes.icl
View file @ 4a1404f8
......@@ -106,7 +106,14 @@ where
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
try_to_expand_synonym_type pos type=:{at_type = TAS {type_index={glob_object,glob_module}} types _} attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
= (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
= case td_rhs of
SynType {at_type}
......@@ -117,8 +124,6 @@ where
-> (No, type_defs, type_heaps, error)
_
-> (No, type_defs, type_heaps, error)
try_to_expand_synonym_type pos type attribute (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
......@@ -365,52 +370,58 @@ where
= (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
{ as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap }))
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
# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
| type_arity <= form_type_arity
# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
| tdi_properties bitand cIsAnalysed == 0
# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
where
is_type_var {at_type = TV _}
= True
is_type_var _
= False
anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
(other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
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)
# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
| type_arity <= form_type_arity
# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
| tdi_properties bitand cIsAnalysed == 0
# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
where
is_type_var {at_type = TV _}
= True
is_type_var _
= False
anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
(other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
= 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 (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
......@@ -475,7 +486,7 @@ cDummyBool :== False
analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_type_var_heap,as_kind_heap})
# {cons_exi_vars,cons_type} = cons_defs.[ds_index ]
(coercible, as_type_var_heap, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_type_var_heap, as_kind_heap)
(cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args