From 35b995a5c9ea0123fe3b33b5ef8b6c6f8d1ee239 Mon Sep 17 00:00:00 2001 From: johnvg Date: Wed, 9 Nov 2011 13:59:03 +0000 Subject: add module expand_types containing some functions from module trans and module typesupport git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2025 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/check.icl | 2 +- frontend/convertcases.icl | 3 +- frontend/convertimportedtypes.icl | 2 +- frontend/expand_types.dcl | 44 ++++ frontend/expand_types.icl | 475 ++++++++++++++++++++++++++++++++++++++ frontend/frontend.icl | 2 +- frontend/overloading.icl | 2 +- frontend/syntax.dcl | 3 +- frontend/trans.dcl | 12 +- frontend/trans.icl | 251 +------------------- frontend/type_io.icl | 5 +- frontend/typesupport.dcl | 10 - frontend/typesupport.icl | 218 +---------------- 13 files changed, 535 insertions(+), 494 deletions(-) create mode 100644 frontend/expand_types.dcl create mode 100644 frontend/expand_types.icl diff --git a/frontend/check.icl b/frontend/check.icl index 3d6e18b..f22866b 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2,7 +2,7 @@ implementation module check import StdEnv, compare_types -import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef +import syntax, expand_types, parse, checksupport, utilities, checktypes, transform, predef import explicitimports, comparedefimp, checkFunctionBodies, containers import genericsupport import typereify diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index a6c68d7..ab38c6d 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -1,8 +1,7 @@ implementation module convertcases -import syntax, compare_types, utilities, typesupport, general +import syntax, compare_types, utilities, expand_types, general from checksupport import ::Component(..),::ComponentMembers(..) -from trans import convertSymbolType // exactZip fails when its arguments are of unequal length exactZip` :: ![.a] ![.b] -> [(.a,.b)] diff --git a/frontend/convertimportedtypes.icl b/frontend/convertimportedtypes.icl index e1ed554..e91a023 100644 --- a/frontend/convertimportedtypes.icl +++ b/frontend/convertimportedtypes.icl @@ -1,6 +1,6 @@ implementation module convertimportedtypes -import syntax, trans +import syntax, expand_types, utilities cDontRemoveAnnotations :== False diff --git a/frontend/expand_types.dcl b/frontend/expand_types.dcl new file mode 100644 index 0000000..5d494fc --- /dev/null +++ b/frontend/expand_types.dcl @@ -0,0 +1,44 @@ +definition module expand_types + +import syntax + +simplifyTypeApplication :: !Type ![AType] -> Type + +convertSymbolType :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap) + +convertSymbolTypeWithoutExpandingAbstractSynTypes :: !Bool !{#CommonDefs} !SymbolType !Int + !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !Bool, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap) + +convertSymbolTypeWithoutCollectingImportedConstructors :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !*TypeHeaps !*VarHeap + -> (!SymbolType, !*ImportedTypes,!*TypeHeaps,!*VarHeap) + +addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] + +RemoveAnnotationsMask:==1 +ExpandAbstractSynTypesMask:==2 +DontCollectImportedConstructors:==4 + +:: ExpandTypeState = + { ets_type_defs :: !.{#{#CheckedTypeDef}} + , ets_collected_conses :: !ImportedConstructors + , ets_type_heaps :: !.TypeHeaps + , ets_var_heap :: !.VarHeap + , ets_main_dcl_module_n :: !Int + , ets_contains_unexpanded_abs_syn_type :: !Bool + } + +class expandSynTypes a :: !Int !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) + +instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b special a=[AType],b=AType + +class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) + +instance substitute Type,AType,TypeContext,AttrInequality,CaseType +instance substitute [a] | substitute a special a=TypeContext +instance substitute (a,b) | substitute a & substitute b special a=[AType],b=AType + +class removeAnnotations a :: !a -> (!Bool, !a) + +instance removeAnnotations Type,SymbolType diff --git a/frontend/expand_types.icl b/frontend/expand_types.icl new file mode 100644 index 0000000..d5e87eb --- /dev/null +++ b/frontend/expand_types.icl @@ -0,0 +1,475 @@ +implementation module expand_types + +import StdEnv +import syntax,predef,containers,utilities + +simplifyTypeApplication :: !Type ![AType] -> Type +simplifyTypeApplication type type_args + # (ok, type) + = simplifyAndCheckTypeApplication type type_args + | not ok + = abort "expand_types.simplifyTypeApplication: unexpected error" + = type + +simplifyAndCheckTypeApplication :: !Type ![AType] -> (!Bool, !Type) +simplifyAndCheckTypeApplication (TA type_cons=:{type_arity} cons_args) type_args + = (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)) +simplifyAndCheckTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args + = (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness) +simplifyAndCheckTypeApplication (CV tv :@: type_args1) type_args2 + = (True, CV tv :@: (type_args1 ++ type_args2)) +simplifyAndCheckTypeApplication TArrow [type1, type2] + = (True, type1 --> type2) +simplifyAndCheckTypeApplication TArrow [type] + = (True, TArrow1 type) +simplifyAndCheckTypeApplication (TArrow1 type1) [type2] + = (True, type1 --> type2) +simplifyAndCheckTypeApplication (TV tv) type_args + = (True, CV tv :@: type_args) +simplifyAndCheckTypeApplication (TempV i) type_args + = (True, TempCV i :@: type_args) +simplifyAndCheckTypeApplication type type_args + = (False, type) + +readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap) +readVarInfo var_info_ptr var_heap + # (var_info, var_heap) = readPtr var_info_ptr var_heap + = case var_info of + VI_Extended _ original_var_info -> (original_var_info, var_heap) + _ -> (var_info, var_heap) + +writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap +writeVarInfo var_info_ptr new_var_info var_heap + # (old_var_info, var_heap) = readPtr var_info_ptr var_heap + = case old_var_info of + VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap + _ -> writePtr var_info_ptr new_var_info var_heap + +RemoveAnnotationsMask:==1 +ExpandAbstractSynTypesMask:==2 +DontCollectImportedConstructors:==4 + +convertSymbolType :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap) +convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + # (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + +convertSymbolTypeWithoutExpandingAbstractSynTypes :: !Bool !{#CommonDefs} !SymbolType !Int + !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !Bool, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap) +convertSymbolTypeWithoutExpandingAbstractSynTypes rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask) 0) common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + +convertSymbolTypeWithoutCollectingImportedConstructors :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !*TypeHeaps !*VarHeap + -> (!SymbolType, !*ImportedTypes,!*TypeHeaps,!*VarHeap) +convertSymbolTypeWithoutCollectingImportedConstructors rem_annots common_defs st main_dcl_module_n imported_types type_heaps var_heap + # (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors) (ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors)) common_defs st main_dcl_module_n imported_types [] type_heaps var_heap + = (st, ets_type_defs, ets_type_heaps, ets_var_heap) + +convertSymbolType_ :: !Int !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap + -> (!SymbolType, !Bool,!*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) +convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + # ets = { ets_type_defs = imported_types + , ets_collected_conses = collected_imports + , ets_type_heaps = type_heaps + , ets_var_heap = var_heap + , ets_main_dcl_module_n = main_dcl_module_n + , ets_contains_unexpanded_abs_syn_type = False + } + # {st_args,st_result,st_context,st_args_strictness} = st + #! (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets + # new_st_args = addTypesOfDictionaries common_defs st_context st_args + new_st_arity = length new_st_args + st = { st + & st_args = new_st_args + , st_result = st_result + , st_arity = new_st_arity + , st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness + , st_context = [] + } + # {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_type} = ets + = (st, ets_contains_unexpanded_abs_syn_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + +addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] +addTypesOfDictionaries common_defs type_contexts type_args + = mapAppend (add_types_of_dictionary common_defs) type_contexts type_args +where + add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_generic_dict={gi_module,gi_index}}, tc_types} + #! generict_dict_ident = predefined_idents.[PD_TypeGenericDict] + /* + AA HACK: + Generic classes are always generated locally, + and therefore the their dictionaries are also generated localy. + Overloaded functions in DCL modules can have generic context restrictions, i.e. they will + get generic class dictionaries. + Problem: DCL function types refer to ICL type defs of dictionaries. + Solution: plug a dummy dictinary type, defined in StdGeneric. + It is possible because all generic class have one class argument and one member. + */ + # dict_type_symb = MakeTypeSymbIdent {glob_object = gi_index, glob_module = gi_module} generict_dict_ident 1 + # type_arg = {at_attribute = TA_Multi, at_type=hd tc_types} + = {at_attribute = TA_Multi, at_type = TA dict_type_symb [type_arg]} + + add_types_of_dictionary common_defs {tc_class = TCClass {glob_module, glob_object={ds_index,ds_ident}}, tc_types} + # {class_arity, class_dictionary={ds_ident,ds_index}, class_cons_vars} + = common_defs.[glob_module].com_class_defs.[ds_index] + dict_type_symb + = MakeTypeSymbIdent {glob_object = ds_index, glob_module = glob_module} ds_ident class_arity + (dict_args,_) = mapSt (\type class_cons_vars + -> let at_attribute = if (class_cons_vars bitand 1<>0) TA_MultiOfPropagatingConsVar TA_Multi + in ({at_attribute = at_attribute, at_type = type}, class_cons_vars>>1) + ) tc_types class_cons_vars + = {at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb dict_args} + +:: ExpandTypeState = + { ets_type_defs :: !.{#{#CheckedTypeDef}} + , ets_collected_conses :: !ImportedConstructors + , ets_type_heaps :: !.TypeHeaps + , ets_var_heap :: !.VarHeap + , ets_main_dcl_module_n :: !Int + , ets_contains_unexpanded_abs_syn_type :: !Bool + } + +class expandSynTypes a :: !Int !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) + +instance expandSynTypes Type +where + expandSynTypes rem_annots common_defs type=:(arg_type --> res_type) ets + # (changed,(arg_type, res_type), ets) = expandSynTypes rem_annots common_defs (arg_type, res_type) ets + | changed + = (True,arg_type --> res_type, ets) + = (False,type, ets) + expandSynTypes rem_annots common_defs type=:(TB _) ets + = (False,type, ets) + expandSynTypes rem_annots common_defs type=:(cons_var :@: types) ets + # (changed,types, ets) = expandSynTypes rem_annots common_defs types ets + | changed + = (True,cons_var :@: types, ets) + = (False,type, ets) + expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets + = expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets + expandSynTypes rem_annots common_defs type=:(TAS type_symb types _) ets + = expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets + expandSynTypes rem_annots common_defs tfa_type=:(TFA vars type) ets + # (changed,type, ets) = expandSynTypes rem_annots common_defs type ets + | changed + = (True,TFA vars type, ets) + = (False,tfa_type, ets) + expandSynTypes rem_annots common_defs type ets + = (False,type, ets) + +instance expandSynTypes [a] | expandSynTypes a +where + expandSynTypes rem_annots common_defs [] ets + = (False,[],ets) + expandSynTypes rem_annots common_defs t=:[type:types] ets + #! (changed_type,type,ets) = expandSynTypes rem_annots common_defs type ets + (changed_types,types,ets) = expandSynTypes rem_annots common_defs types ets + | changed_type || changed_types + = (True,[type:types],ets) + = (False,t,ets) + +instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b +where + expandSynTypes rem_annots common_defs (type1,type2) ets + #! (changed_type1,type1,ets) = expandSynTypes rem_annots common_defs type1 ets + (changed_type2,type2,ets) = expandSynTypes rem_annots common_defs type2 ets + = (changed_type1 || changed_type2,(type1,type2),ets) + +instance expandSynTypes AType +where + expandSynTypes rem_annots common_defs atype ets + = expand_syn_types_in_a_type rem_annots common_defs atype ets + where + expand_syn_types_in_a_type :: !.Int !{#.CommonDefs} !.AType !*ExpandTypeState -> (!.Bool,!AType,!.ExpandTypeState) + expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TA type_symb types,at_attribute} ets + # (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets + | changed + = (True,{ atype & at_type = at_type }, ets) + = (False,atype,ets) + expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TAS type_symb types _,at_attribute} ets + # (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets + | changed + = (True,{ atype & at_type = at_type }, ets) + = (False,atype,ets) + expand_syn_types_in_a_type rem_annots common_defs atype ets + # (changed,at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets + | changed + = (True,{ atype & at_type = at_type }, ets) + = (False,atype,ets) + +expand_syn_types_in_TA :: !.Int !{#.CommonDefs} !.Type !.TypeAttribute !*ExpandTypeState -> (!Bool,!Type,!.ExpandTypeState) +expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_defs} + # (glob_object,glob_module,types) = case ta_type of + (TA type_symb=:{type_index={glob_object,glob_module},type_ident} types) -> (glob_object,glob_module,types) + (TAS type_symb=:{type_index={glob_object,glob_module},type_ident} types strictness) -> (glob_object,glob_module,types) + # ({td_rhs,td_ident,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object] + ets = { ets & ets_type_defs = ets_type_defs } + = case td_rhs of + SynType rhs_type + # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps + # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + -> (True,type,ets) + AbstractSynType _ rhs_type + | (rem_annots bitand ExpandAbstractSynTypesMask)<>0 + # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps + # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + -> (True,type,ets) + + # ets = {ets & ets_contains_unexpanded_abs_syn_type=True } + #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets + # ta_type = if changed + ( case ta_type of + TA type_symb _ -> TA type_symb types + TAS type_symb _ strictness -> TAS type_symb types strictness + ) ta_type + | glob_module == ets.ets_main_dcl_module_n + -> (changed,ta_type, ets) + -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) + NewType {ds_index} + # {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index]; + # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute arg_type rem_annots attribute ets.ets_type_heaps + # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + -> (True,type,ets) + _ + #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets + # ta_type = if changed + ( case ta_type of + TA type_symb _ -> TA type_symb types + TAS type_symb _ strictness -> TAS type_symb types strictness + ) ta_type + | glob_module == ets.ets_main_dcl_module_n || (rem_annots bitand DontCollectImportedConstructors)<>0 + -> (changed,ta_type, ets) + -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) +where + bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps + # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps + ets_type_heaps = fold2St bind_var_and_attr td_args types ets_type_heaps + = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps + where + bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } + bind_var_and_attr { atv_variable = {tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + + bind_attr (TA_Var {av_info_ptr}) attribute type_heaps=:{th_attrs} + = { type_heaps & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attribute) } + bind_attr _ attribute type_heaps + = type_heaps + + substitute_rhs rem_annots rhs_type type_heaps + | (rem_annots bitand RemoveAnnotationsMask)<>0 + # (_, rhs_type) = removeAnnotations rhs_type + = substitute rhs_type type_heaps + = substitute rhs_type type_heaps + + collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState + collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap} + # (ets_collected_conses, ets_var_heap) + = collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs rt_constructor (ets_collected_conses, ets_var_heap) + = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } + collect_imported_constructors common_defs mod_index (AlgType constructors) ets=:{ets_collected_conses,ets_var_heap} + # (ets_collected_conses, ets_var_heap) + = foldSt (collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs) constructors (ets_collected_conses, ets_var_heap) + = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } + collect_imported_constructors common_defs mod_index _ ets + = ets + + collect_imported_constructor :: !.Int !{#.ConsDef} !.DefinedSymbol !*(!u:[v:(Global .Int)],!*(Heap VarInfo)) -> (!w:[x:(Global Int)],!.(Heap VarInfo)), [u <= w,v <= x] + collect_imported_constructor mod_index cons_defs {ds_index} (collected_conses, var_heap) + # {cons_type_ptr} = cons_defs.[ds_index] + (type_info, var_heap) = readVarInfo cons_type_ptr var_heap + | has_been_collected type_info + = (collected_conses, var_heap) + = ([{ glob_module = mod_index, glob_object = ds_index } : collected_conses ], writeVarInfo cons_type_ptr VI_Used var_heap) + where + has_been_collected VI_Used = True + has_been_collected (VI_ExpandedType _) = True + has_been_collected _ = False + +class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) + +instance substitute AType +where + substitute atype=:{at_attribute,at_type} heaps + # ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps + = ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps) + +instance substitute TypeAttribute +where + substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs} + #! av_info = sreadPtr av_info_ptr th_attrs + = case av_info of + AVI_Attr attr + -> (attr, heaps) + _ + -> (TA_Multi, heaps) + substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs} + #! av_info = sreadPtr av_info_ptr th_attrs + = case av_info of + AVI_Attr attr + -> (attr, heaps) + _ + -> (TA_Multi, heaps) + substitute TA_None heaps + = (TA_Multi, heaps) + substitute attr heaps + = (attr, heaps) + +instance substitute (a,b) | substitute a & substitute b +where + substitute (x,y) heaps + # (x, heaps) = substitute x heaps + (y, heaps) = substitute y heaps + = ((x,y), heaps) + +instance substitute [a] | substitute a +where + substitute [] heaps + = ( [], heaps) + substitute [t:ts] heaps + # (t, heaps) = substitute t heaps + ( ts, heaps) = substitute ts heaps + = ([t:ts], heaps) + +instance substitute TypeContext +where + substitute tc=:{tc_types} heaps + # (tc_types, heaps) = substitute tc_types heaps + = ({ tc & tc_types = tc_types }, heaps) + +instance substitute Type +where + substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars} + # (tv_info, th_vars) = readPtr tv_info_ptr th_vars + heaps = {heaps & th_vars = th_vars} + = case tv_info of + TVI_Type type + -> (type, heaps) + _ + -> (tv, heaps) + substitute (arg_type --> res_type) heaps + # ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps + = (arg_type --> res_type, heaps) + substitute (TArrow1 arg_type) heaps + # (arg_type, heaps) = substitute arg_type heaps + = (TArrow1 arg_type, heaps) + substitute (TA cons_id cons_args) heaps + # (cons_args, heaps) = substitute cons_args heaps + = (TA cons_id cons_args, heaps) + substitute (TAS cons_id cons_args strictness) heaps + # (cons_args, heaps) = substitute cons_args heaps + = (TAS cons_id cons_args strictness, heaps) + substitute (CV type_var :@: types) heaps=:{th_vars} + # (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars + heaps = {heaps & th_vars = th_vars} + (types, heaps) = substitute types heaps + = case tv_info of + TVI_Type type + # (ok, simplified_type) = simplifyAndCheckTypeApplication type types + | ok + -> (simplified_type, heaps) + // otherwise + // this will lead to a kind check error later on + -> (CV type_var :@: types, heaps) + -> (CV type_var :@: types, heaps) + substitute type heaps + = (type, heaps) + +instance substitute AttributeVar +where + substitute av=:{av_info_ptr} heaps=:{th_attrs} + #! av_info = sreadPtr av_info_ptr th_attrs + = case av_info of + AVI_Attr (TA_Var attr_var) + -> (attr_var, heaps) + _ + -> (av, heaps) + +instance substitute AttrInequality +where + substitute {ai_demanded,ai_offered} heaps + # ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps + = ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps) + +instance substitute CaseType +where + substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps + # (ct_pattern_type, heaps) = substitute ct_pattern_type heaps + (ct_result_type, heaps) = substitute ct_result_type heaps + (ct_cons_types, heaps) = substitute ct_cons_types heaps + = ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, + ct_cons_types = ct_cons_types}, heaps) + +class removeAnnotations a :: !a -> (!Bool, !a) + +instance removeAnnotations (a,b) | removeAnnotations a & removeAnnotations b +where + removeAnnotations t=:(x,y) + # (rem_x, x) = removeAnnotations x + (rem_y, y) = removeAnnotations y + | rem_x || rem_y + = (True, (x,y)) + = (False, t) + +instance removeAnnotations [a] | removeAnnotations a +where + removeAnnotations l=:[x:xs] + # (rem_x, x) = removeAnnotations x + (rem_xs, xs) = removeAnnotations xs + | rem_x || rem_xs + = (True, [x:xs]) + = (False, l) + removeAnnotations el + = (False, el) + +instance removeAnnotations Type +where + removeAnnotations t=:(arg_type --> res_type) + # (rem, (arg_type, res_type)) = removeAnnotations (arg_type, res_type) + | rem + = (True, arg_type --> res_type) + = (False, t) + removeAnnotations t=:(TA cons_id cons_args) + # (rem, cons_args) = removeAnnotations cons_args + | rem + = (True, TA cons_id cons_args) + = (False, t) + removeAnnotations t=:(TAS cons_id cons_args _) + # (rem, cons_args) = removeAnnotations cons_args + | rem + = (True, TA cons_id cons_args) + = (False, t) + removeAnnotations t=:(TArrow1 arg_type) + # (rem, arg_type) = removeAnnotations arg_type + | rem + = (True, TArrow1 arg_type) + = (False, t) + removeAnnotations t=:(cv :@: types) + # (rem, types) = removeAnnotations types + | rem + = (True, cv :@: types) + = (False, t) + removeAnnotations type + = (False, type) + +instance removeAnnotations AType +where + removeAnnotations atype=:{at_type} + # (rem, at_type) = removeAnnotations at_type + | rem + = (True, { atype & at_type = at_type }) + = (False, atype) + +instance removeAnnotations SymbolType +where + removeAnnotations st=:{st_args,st_result,st_args_strictness} + # (rem, (st_args,st_result)) = removeAnnotations (st_args,st_result) + | rem + = (True, { st & st_args = st_args, st_args_strictness=NotStrict, st_result = st_result }) + | is_not_strict st_args_strictness + = (False, st) + = (True, { st & st_args_strictness=NotStrict }) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index c14b9c2..19ab547 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -3,7 +3,7 @@ */ implementation module frontend -import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics, +import scanner, parse, postparse, check, type, trans, partition, convertcases, overloading, utilities, convertDynamics, convertimportedtypes, compilerSwitches, analtypes, generics1, typereify, compare_types diff --git a/frontend/overloading.icl b/frontend/overloading.icl index f97389b..63bafc9 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,7 +2,7 @@ implementation module overloading import StdEnv, compare_types -import syntax, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics +import syntax, type, expand_types, utilities, unitype, predef, checktypes, convertDynamics import genericsupport, type_io_common :: LocalTypePatternVariable = diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 6b14923..0c7e306 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -4,8 +4,9 @@ import StdEnv import scanner, general, typeproperties, Heap import IndexType - from containers import ::NumberSet +from convertDynamics import :: TypeCodeVariableInfo, :: DynamicValueAliasInfo +from convertcases import :: LetVarInfo, :: LetExpressionInfo, :: RefCountsInCase, :: SplitsInCase :: Ident = { id_name :: !String diff --git a/frontend/trans.dcl b/frontend/trans.dcl index 96f17c7..82363ef 100644 --- a/frontend/trans.dcl +++ b/frontend/trans.dcl @@ -1,18 +1,8 @@ definition module trans import StdEnv - -import syntax, transform -import classify, partition +import syntax,classify,predef transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Component} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*ImportedTypes !*TypeDefInfos !*VarHeap !*TypeHeaps !*ExpressionHeap !Bool !*File !*PredefinedSymbols -> (!*{!Component}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols) - -convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap - -> (!SymbolType, !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) - -convertSymbolTypeWithoutCollectingImportedConstructors :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !*TypeHeaps !*VarHeap - -> (!SymbolType, !*ImportedTypes, !*TypeHeaps, !*VarHeap) - -addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] diff --git a/frontend/trans.icl b/frontend/trans.icl index f8cc889..fd4ef9e 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -2,7 +2,7 @@ implementation module trans import StdEnv -import syntax, transform, checksupport, compare_types, check, utilities, unitype, typesupport, type +import syntax, transform, checksupport, compare_types, check, utilities, expand_types, unitype, typesupport, type import classify, partition SwitchCaseFusion fuse dont_fuse :== fuse @@ -3807,8 +3807,8 @@ where , ets_main_dcl_module_n = main_dcl_module_n , ets_contains_unexpanded_abs_syn_type = False } - #! (_,(st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) - = expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_result,st_args) ets + #! (_,(st_args,st_result), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) + = expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_args,st_result) ets # ft = { ft & st_result = st_result, st_args = st_args } | fi_group_index >= size groups = abort ("add_new_function_to_group "+++ toString fi_group_index+++ "," +++ toString (size groups) +++ "," +++ toString gf_fun_index) @@ -3832,7 +3832,7 @@ where = fun_defs![fun_index] rem_annot = fi_properties bitand FI_HasTypeSpec == 0 (fun_type,contains_unexpanded_abs_syn_type,imported_types, collected_imports, type_heaps, var_heap) - = convertSymbolType_ (if rem_annot RemoveAnnotationsMask 0) common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap + = convertSymbolTypeWithoutExpandingAbstractSynTypes rem_annot common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap # fun_def = { fun_def & fun_type = Yes fun_type } fun_defs = { fun_defs & [fun_index] = fun_def } | contains_unexpanded_abs_syn_type @@ -3844,8 +3844,8 @@ where # (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs) = fun_defs![fun_index] rem_annot = fi_properties bitand FI_HasTypeSpec == 0 - (fun_type,contains_unexpanded_abs_syn_type,imported_types, collected_imports, type_heaps, var_heap) - = convertSymbolType_ (if rem_annot (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap + (fun_type,imported_types, collected_imports, type_heaps, var_heap) + = convertSymbolType rem_annot common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap fun_def = { fun_def & fun_type = Yes fun_type} fun_defs = { fun_defs & [fun_index] = fun_def } = (fun_defs, imported_types, collected_imports, type_heaps, var_heap) @@ -3867,245 +3867,6 @@ where # (members,fun_heap) = determine_new_functions_in_component (n_functions-1) new_functions before after fun_heap = (GeneratedComponentMember gf_fun_index fun_ptr members,fun_heap) -RemoveAnnotationsMask:==1 -ExpandAbstractSynTypesMask:==2 -DontCollectImportedConstructors:==4 - -convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap - -> (!SymbolType, !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) -convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap - # (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) - = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap - = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) - -convertSymbolTypeWithoutCollectingImportedConstructors :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !*TypeHeaps !*VarHeap - -> (!SymbolType, !*ImportedTypes, !*TypeHeaps, !*VarHeap) -convertSymbolTypeWithoutCollectingImportedConstructors rem_annots common_defs st main_dcl_module_n imported_types type_heaps var_heap - # (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) - = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors) (ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors)) common_defs st main_dcl_module_n imported_types [] type_heaps var_heap - = (st, ets_type_defs, ets_type_heaps, ets_var_heap) - -convertSymbolType_ :: !Int !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap - -> (!SymbolType, !Bool,!*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) -convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap - # ets = { ets_type_defs = imported_types - , ets_collected_conses = collected_imports - , ets_type_heaps = type_heaps - , ets_var_heap = var_heap - , ets_main_dcl_module_n = main_dcl_module_n - , ets_contains_unexpanded_abs_syn_type = False - } - # {st_args,st_result,st_context,st_args_strictness} = st - #! (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets - # new_st_args = addTypesOfDictionaries common_defs st_context st_args - new_st_arity = length new_st_args - st = { st - & st_args = new_st_args - , st_result = st_result - , st_arity = new_st_arity - , st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness - , st_context = [] - } - # {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_type} = ets - = (st, ets_contains_unexpanded_abs_syn_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) - -addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] -addTypesOfDictionaries common_defs type_contexts type_args - = mapAppend (add_types_of_dictionary common_defs) type_contexts type_args -where - add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_generic_dict={gi_module,gi_index}}, tc_types} - #! generict_dict_ident = predefined_idents.[PD_TypeGenericDict] - /* - AA HACK: - Generic classes are always generated locally, - and therefore the their dictionaries are also generated localy. - Overloaded functions in DCL modules can have generic context restrictions, i.e. they will - get generic class dictionaries. - Problem: DCL function types refer to ICL type defs of dictionaries. - Solution: plug a dummy dictinary type, defined in StdGeneric. - It is possible because all generic class have one class argument and one member. - */ - # dict_type_symb = MakeTypeSymbIdent {glob_object = gi_index, glob_module = gi_module} generict_dict_ident 1 - # type_arg = {at_attribute = TA_Multi, at_type=hd tc_types} - = {at_attribute = TA_Multi, at_type = TA dict_type_symb [type_arg]} - - add_types_of_dictionary common_defs {tc_class = TCClass {glob_module, glob_object={ds_index,ds_ident}}, tc_types} - # {class_arity, class_dictionary={ds_ident,ds_index}, class_cons_vars} - = common_defs.[glob_module].com_class_defs.[ds_index] - dict_type_symb - = MakeTypeSymbIdent {glob_object = ds_index, glob_module = glob_module} ds_ident class_arity - (dict_args,_) = mapSt (\type class_cons_vars - -> let at_attribute = if (class_cons_vars bitand 1<>0) TA_MultiOfPropagatingConsVar TA_Multi - in ({at_attribute = at_attribute, at_type = type}, class_cons_vars>>1) - ) tc_types class_cons_vars - = {at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb dict_args} - -:: ExpandTypeState = - { ets_type_defs :: !.{#{#CheckedTypeDef}} - , ets_collected_conses :: !ImportedConstructors - , ets_type_heaps :: !.TypeHeaps - , ets_var_heap :: !.VarHeap - , ets_main_dcl_module_n :: !Int - , ets_contains_unexpanded_abs_syn_type :: !Bool - } - -class expandSynTypes a :: !Int !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) - -instance expandSynTypes Type -where - expandSynTypes rem_annots common_defs type=:(arg_type --> res_type) ets - # (changed,(arg_type, res_type), ets) = expandSynTypes rem_annots common_defs (arg_type, res_type) ets - | changed - = (True,arg_type --> res_type, ets) - = (False,type, ets) - expandSynTypes rem_annots common_defs type=:(TB _) ets - = (False,type, ets) - expandSynTypes rem_annots common_defs type=:(cons_var :@: types) ets - # (changed,types, ets) = expandSynTypes rem_annots common_defs types ets - | changed - = (True,cons_var :@: types, ets) - = (False,type, ets) - expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets - = expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets - expandSynTypes rem_annots common_defs type=:(TAS type_symb types _) ets - = expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets - expandSynTypes rem_annots common_defs tfa_type=:(TFA vars type) ets - # (changed,type, ets) = expandSynTypes rem_annots common_defs type ets - | changed - = (True,TFA vars type, ets) - = (False,tfa_type, ets) - expandSynTypes rem_annots common_defs type ets - = (False,type, ets) - -instance expandSynTypes [a] | expandSynTypes a -where - expandSynTypes rem_annots common_defs [] ets - = (False,[],ets) - expandSynTypes rem_annots common_defs t=:[type:types] ets - #! (changed_type,type,ets) = expandSynTypes rem_annots common_defs type ets - (changed_types,types,ets) = expandSynTypes rem_annots common_defs types ets - | changed_type || changed_types - = (True,[type:types],ets) - = (False,t,ets) - -instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b -where - expandSynTypes rem_annots common_defs (type1,type2) ets - #! (changed_type1,type1,ets) = expandSynTypes rem_annots common_defs type1 ets - (changed_type2,type2,ets) = expandSynTypes rem_annots common_defs type2 ets - = (changed_type1 || changed_type2,(type1,type2),ets) - -instance expandSynTypes AType -where - expandSynTypes rem_annots common_defs atype ets - = expand_syn_types_in_a_type rem_annots common_defs atype ets - where - expand_syn_types_in_a_type :: !.Int !{#.CommonDefs} !.AType !*ExpandTypeState -> (!.Bool,!AType,!.ExpandTypeState) - expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TA type_symb types,at_attribute} ets - # (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets - | changed - = (True,{ atype & at_type = at_type }, ets) - = (False,atype,ets) - expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TAS type_symb types _,at_attribute} ets - # (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets - | changed - = (True,{ atype & at_type = at_type }, ets) - = (False,atype,ets) - expand_syn_types_in_a_type rem_annots common_defs atype ets - # (changed,at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets - | changed - = (True,{ atype & at_type = at_type }, ets) - = (False,atype,ets) - -expand_syn_types_in_TA :: !.Int !{#.CommonDefs} !.Type !.TypeAttribute !*ExpandTypeState -> (!Bool,!Type,!.ExpandTypeState) -expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_defs} - # (glob_object,glob_module,types) = case ta_type of - (TA type_symb=:{type_index={glob_object,glob_module},type_ident} types) -> (glob_object,glob_module,types) - (TAS type_symb=:{type_index={glob_object,glob_module},type_ident} types strictness) -> (glob_object,glob_module,types) - # ({td_rhs,td_ident,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object] - ets = { ets & ets_type_defs = ets_type_defs } - = case td_rhs of - SynType rhs_type - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) - AbstractSynType _ rhs_type - | (rem_annots bitand ExpandAbstractSynTypesMask)<>0 - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) - - # ets = {ets & ets_contains_unexpanded_abs_syn_type=True } - #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets - # ta_type = if changed - ( case ta_type of - TA type_symb _ -> TA type_symb types - TAS type_symb _ strictness -> TAS type_symb types strictness - ) ta_type - | glob_module == ets.ets_main_dcl_module_n - -> (changed,ta_type, ets) - -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) - NewType {ds_index} - # {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index]; - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute arg_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) - _ - #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets - # ta_type = if changed - ( case ta_type of - TA type_symb _ -> TA type_symb types - TAS type_symb _ strictness -> TAS type_symb types strictness - ) ta_type - | glob_module == ets.ets_main_dcl_module_n || (rem_annots bitand DontCollectImportedConstructors)<>0 - -> (changed,ta_type, ets) - -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) -where - bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps - # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps - ets_type_heaps = fold2St bind_var_and_attr td_args types ets_type_heaps - = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps - where - bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } - bind_var_and_attr { atv_variable = {tv_info_ptr}} {at_type} type_heaps=:{th_vars} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } - - bind_attr (TA_Var {av_info_ptr}) attribute type_heaps=:{th_attrs} - = { type_heaps & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attribute) } - bind_attr _ attribute type_heaps - = type_heaps - - substitute_rhs rem_annots rhs_type type_heaps - | (rem_annots bitand RemoveAnnotationsMask)<>0 - # (_, rhs_type) = removeAnnotations rhs_type - = substitute rhs_type type_heaps - = substitute rhs_type type_heaps - - collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState - collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap} - # (ets_collected_conses, ets_var_heap) - = collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs rt_constructor (ets_collected_conses, ets_var_heap) - = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } - collect_imported_constructors common_defs mod_index (AlgType constructors) ets=:{ets_collected_conses,ets_var_heap} - # (ets_collected_conses, ets_var_heap) - = foldSt (collect_imported_constructor mod_index common_defs.[mod_index].com_cons_defs) constructors (ets_collected_conses, ets_var_heap) - = { ets & ets_collected_conses = ets_collected_conses, ets_var_heap = ets_var_heap } - collect_imported_constructors common_defs mod_index _ ets - = ets - - collect_imported_constructor :: !.Int !{#.ConsDef} !.DefinedSymbol !*(!u:[v:(Global .Int)],!*(Heap VarInfo)) -> (!w:[x:(Global Int)],!.(Heap VarInfo)), [u <= w,v <= x] - collect_imported_constructor mod_index cons_defs {ds_index} (collected_conses, var_heap) - # {cons_type_ptr} = cons_defs.[ds_index] - (type_info, var_heap) = readVarInfo cons_type_ptr var_heap - | has_been_collected type_info - = (collected_conses, var_heap) - = ([{ glob_module = mod_index, glob_object = ds_index } : collected_conses ], writeVarInfo cons_type_ptr VI_Used var_heap) - where - has_been_collected VI_Used = True - has_been_collected (VI_ExpandedType _) = True - has_been_collected _ = False - //@ freeVariables class clearVariables expr :: !expr !*VarHeap -> *VarHeap diff --git a/frontend/type_io.icl b/frontend/type_io.icl index bccdeb6..97d4093 100644 --- a/frontend/type_io.icl +++ b/frontend/type_io.icl @@ -1,11 +1,8 @@ -/* - module owner: Martijn Vervoort -*/ implementation module type_io import StdEnv, compare_constructor import scanner, general, Heap, typeproperties, utilities, checksupport -from trans import convertSymbolTypeWithoutCollectingImportedConstructors +from expand_types import convertSymbolTypeWithoutCollectingImportedConstructors import type_io_common from genericsupport import kind_to_short_string diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index 1a2d70a..df09e7a 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -6,7 +6,6 @@ from unitype import ::Coercions, ::CoercionTree, ::AttributePartition, CT_Empty errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin -// MW4 was:class (<::) infixl a :: !*File (!Format, !a) -> *File (<::) infixl :: !*File !(!Format, !a, !Optional TypeVarBeautifulizer) -> *File | writeType a class writeType a :: !*File !(Optional TypeVarBeautifulizer) !(!Format, !a) -> (!*File, !Optional TypeVarBeautifulizer) @@ -66,11 +65,6 @@ beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHe updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) -class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) - -instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a, - (a,b) | substitute a & substitute b - substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps) bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; @@ -134,10 +128,6 @@ initializeToAVI_Empty :: !AttributeVar !*AttrVarHeap -> .AttrVarHeap appTypeVarHeap f type_heaps :== let th_vars = f type_heaps.th_vars in { type_heaps & th_vars = th_vars } accTypeVarHeap f type_heaps :== let (r, th_vars) = f type_heaps.th_vars in (r, { type_heaps & th_vars = th_vars }) accAttrVarHeap f type_heaps :== let (r, th_attrs) = f type_heaps.th_attrs in (r, { type_heaps & th_attrs = th_attrs }) - -class removeAnnotations a :: !a -> (!Bool, !a) - -instance removeAnnotations Type, SymbolType foldATypeSt on_atype on_type type st :== fold_atype_st type st where diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 6f1b229..08a9686 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -1,7 +1,7 @@ implementation module typesupport import StdEnv, compare_types -import syntax, unitype, utilities, checktypes +import syntax, expand_types, unitype, utilities, checktypes :: Store :== Int @@ -23,34 +23,6 @@ import syntax, unitype, utilities, checktypes | UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType -simplifyTypeApplication :: !Type ![AType] -> Type -simplifyTypeApplication type type_args - # (ok, type) - = simplifyAndCheckTypeApplication type type_args - | not ok - = abort "typesupport.simplifyTypeApplication: unexpected error" - = type - -simplifyAndCheckTypeApplication :: !Type ![AType] -> (!Bool, !Type) -simplifyAndCheckTypeApplication (TA type_cons=:{type_arity} cons_args) type_args - = (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)) -simplifyAndCheckTypeApplication (TAS type_cons=:{type_arity} cons_args strictness) type_args - = (True, TAS { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) strictness) -simplifyAndCheckTypeApplication (CV tv :@: type_args1) type_args2 - = (True, CV tv :@: (type_args1 ++ type_args2)) -simplifyAndCheckTypeApplication TArrow [type1, type2] - = (True, type1 --> type2) -simplifyAndCheckTypeApplication TArrow [type] - = (True, TArrow1 type) -simplifyAndCheckTypeApplication (TArrow1 type1) [type2] - = (True, type1 --> type2) -simplifyAndCheckTypeApplication (TV tv) type_args - = (True, CV tv :@: type_args) -simplifyAndCheckTypeApplication (TempV i) type_args - = (True, TempCV i :@: type_args) -simplifyAndCheckTypeApplication type type_args - = (False, type) - :: AttributeEnv :== {! TypeAttribute } :: VarEnv :== {! Type } @@ -557,7 +529,6 @@ where = cus_error = startRuleError "Start rule cannot be overloaded.\n" cus_error = cus_error - instance clean_up CaseType where @@ -699,193 +670,6 @@ where clear_attribute _ th_attrs = th_attrs -class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) - -instance substitute AType -where - substitute atype=:{at_attribute,at_type} heaps - # ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps - = ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps) - -instance substitute TypeAttribute -where - substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs} - #! av_info = sreadPtr av_info_ptr th_attrs - = case av_info of - AVI_Attr attr - -> (attr, heaps) - _ - -> (TA_Multi, heaps) - substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs} - #! av_info = sreadPtr av_info_ptr th_attrs - = case av_info of - AVI_Attr attr - -> (attr, heaps) - _ - -> (TA_Multi, heaps) - substitute TA_None heaps - = (TA_Multi, heaps) - substitute attr heaps - = (attr, heaps) - -instance substitute (a,b) | substitute a & substitute b -where - substitute (x,y) heaps - # (x, heaps) = substitute x heaps - (y, heaps) = substitute y heaps - = ((x,y), heaps) - -instance substitute [a] | substitute a -where - substitute [] heaps - = ( [], heaps) - substitute [t:ts] heaps - # (t, heaps) = substitute t heaps - ( ts, heaps) = substitute ts heaps - = ([t:ts], heaps) - -instance substitute TypeContext -where - substitute tc=:{tc_types} heaps - # (tc_types, heaps) = substitute tc_types heaps - = ({ tc & tc_types = tc_types }, heaps) - -instance substitute Type -where - substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars} - # (tv_info, th_vars) = readPtr tv_info_ptr th_vars - heaps = {heaps & th_vars = th_vars} - = case tv_info of - TVI_Type type - -> (type, heaps) - _ - -> (tv, heaps) - substitute (arg_type --> res_type) heaps - # ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps - = (arg_type --> res_type, heaps) - substitute (TArrow1 arg_type) heaps - # (arg_type, heaps) = substitute arg_type heaps - = (TArrow1 arg_type, heaps) - substitute (TA cons_id cons_args) heaps - # (cons_args, heaps) = substitute cons_args heaps - = (TA cons_id cons_args, heaps) - substitute (TAS cons_id cons_args strictness) heaps - # (cons_args, heaps) = substitute cons_args heaps - = (TAS cons_id cons_args strictness, heaps) - substitute (CV type_var :@: types) heaps=:{th_vars} - # (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars - heaps = {heaps & th_vars = th_vars} - (types, heaps) = substitute types heaps - = case tv_info of - TVI_Type type - # (ok, simplified_type) = simplifyAndCheckTypeApplication type types - | ok - -> (simplified_type, heaps) - // otherwise - // this will lead to a kind check error later on - -> (CV type_var :@: types, heaps) - -> (CV type_var :@: types, heaps) - substitute type heaps - = (type, heaps) - -instance substitute AttributeVar -where - substitute av=:{av_info_ptr} heaps=:{th_attrs} - #! av_info = sreadPtr av_info_ptr th_attrs - = case av_info of - AVI_Attr (TA_Var attr_var) - -> (attr_var, heaps) - _ - -> (av, heaps) - -instance substitute AttrInequality -where - substitute {ai_demanded,ai_offered} heaps - # ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps - = ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps) - -instance substitute CaseType -where - substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps - # (ct_pattern_type, heaps) = substitute ct_pattern_type heaps - (ct_result_type, heaps) = substitute ct_result_type heaps - (ct_cons_types, heaps) = substitute ct_cons_types heaps - = ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, - ct_cons_types = ct_cons_types}, heaps) - -class removeAnnotations a :: !a -> (!Bool, !a) - -instance removeAnnotations (a,b) | removeAnnotations a & removeAnnotations b -where - removeAnnotations t=:(x,y) - # (rem_x, x) = removeAnnotations x - (rem_y, y) = removeAnnotations y - | rem_x || rem_y - = (True, (x,y)) - = (False, t) - -instance removeAnnotations [a] | removeAnnotations a -where - removeAnnotations l=:[x:xs] - # (rem_x, x) = removeAnnotations x - (rem_xs, xs) = removeAnnotations xs - | rem_x || rem_xs - = (True, [x:xs]) - = (False, l) - removeAnnotations el - = (False, el) - -instance removeAnnotations Type -where - removeAnnotations t=:(arg_type --> res_type) - # (rem, (arg_type, res_type)) = removeAnnotations (arg_type, res_type) - | rem - = (True, arg_type --> res_type) - = (False, t) -//AA.. - removeAnnotations t=:(TArrow1 arg_type) - # (rem, arg_type) = removeAnnotations arg_type - | rem - = (True, TArrow1 arg_type) - = (False, t) -//..AA - removeAnnotations t=:(TA cons_id cons_args) - # (rem, cons_args) = removeAnnotations cons_args - | rem - = (True, TA cons_id cons_args) - = (False, t) - removeAnnotations t=:(TAS cons_id cons_args _) - # (rem, cons_args) = removeAnnotations cons_args - | rem - = (True, TA cons_id cons_args) - = (False, t) - removeAnnotations t=:(cv :@: types) - # (rem, types) = removeAnnotations types - | rem - = (True, cv :@: types) - = (False, t) - removeAnnotations type - = (False, type) - - -instance removeAnnotations AType -where - removeAnnotations atype=:{at_type} - # (rem, at_type) = removeAnnotations at_type - | rem - = (True, { atype & at_type = at_type }) - = (False, atype) - -instance removeAnnotations SymbolType -where - removeAnnotations st=:{st_args,st_result,st_args_strictness} - # (rem, (st_args,st_result)) = removeAnnotations (st_args,st_result) - | rem - = (True, { st & st_args = st_args, st_args_strictness=NotStrict, st_result = st_result }) - | is_not_strict st_args_strictness - = (False, st) - = (True, { st & st_args_strictness=NotStrict }) - /* expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} -- cgit v1.2.3