diff options
| -rw-r--r-- | frontend/analtypes.dcl | 12 | ||||
| -rw-r--r-- | frontend/analtypes.icl | 436 | ||||
| -rw-r--r-- | frontend/check.icl | 7 | ||||
| -rw-r--r-- | frontend/checktypes.dcl | 16 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 172 | ||||
| -rw-r--r-- | frontend/frontend.icl | 17 | ||||
| -rw-r--r-- | frontend/generics.icl | 25 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 6 | ||||
| -rw-r--r-- | frontend/syntax.icl | 20 |
9 files changed, 471 insertions, 240 deletions
diff --git a/frontend/analtypes.dcl b/frontend/analtypes.dcl index 22b25d3..96f8d2d 100644 --- a/frontend/analtypes.dcl +++ b/frontend/analtypes.dcl @@ -7,4 +7,14 @@ partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*Type :: TypeGroups :== [[GlobalIndex]] -analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) +analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) + +determineKindsOfClasses :: !NumberSet !{#CommonDefs} !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin + -> (!*ClassDefInfos, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) + +checkKindsOfCommonDefsAndFunctions :: !Index !Index !NumberSet !IndexRange !{#CommonDefs} !u:{# FunDef} !v:{#DclModule} !*TypeDefInfos !*ClassDefInfos + !*TypeVarHeap !*ErrorAdmin -> (!u:{# FunDef}, !v:{#DclModule}, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) + +isATopConsVar cv :== cv < 0 +encodeTopConsVar cv :== dec (~cv) +decodeTopConsVar cv :== ~(inc cv) diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index d616b2c..3724b07 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -26,7 +26,6 @@ import syntax, checksupport, checktypes, check, typesupport, utilities, analunit cNotPartitionated :== -1 cChecking :== -1 - partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin -> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin) partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{com_type_defs,com_class_defs} dcl_modules type_heaps error @@ -52,9 +51,9 @@ partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{ = (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs}, dcl_modules, type_heaps, error) where copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (icl_type_defs, dcl_modules) - # type_defs = { {} \\ nr_of_types <- [0..nr_of_modules] } - marks = { {} \\ nr_of_types <- [0..nr_of_modules] } - type_def_infos = { {} \\ nr_of_types <- [0..nr_of_modules] } + # type_defs = { {} \\ module_nr <- [0..nr_of_modules] } + marks = { {} \\ module_nr <- [0..nr_of_modules] } + type_def_infos = { {} \\ module_nr <- [0..nr_of_modules] } = iFoldSt (copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod) 0 nr_of_modules (icl_type_defs, dcl_modules, type_defs, marks, type_def_infos) where @@ -256,45 +255,53 @@ where -> { uni_info & uki_kind_heap = uki_kind_heap, uki_error = kindError kind1 kind2 uni_info.uki_error } -> { uni_info & uki_kind_heap = uki_kind_heap <:= (info_ptr1, kind2) } where - contains_kind_ptr info_ptr (KI_Arrow kinds) kind_heap - = kinds_contains_kind_ptr info_ptr kinds kind_heap + contains_kind_ptr info_ptr (KI_Arrow kind1 kind2) kind_heap + # (kind1, kind_heap) = skipIndirections kind1 kind_heap + # (found, kind_heap) = contains_kind_ptr info_ptr kind1 kind_heap + | found + = (True, kind_heap) + # (kind2, kind_heap) = skipIndirections kind2 kind_heap + = contains_kind_ptr info_ptr kind2 kind_heap contains_kind_ptr info_ptr (KI_Var kind_info_ptr) kind_heap = (info_ptr == kind_info_ptr, kind_heap) contains_kind_ptr info_ptr (KI_Const) kind_heap = (False, kind_heap) - kinds_contains_kind_ptr info_ptr [ kind : kinds ] kind_heap - # (kind, kind_heap) = skipIndirections kind kind_heap - (found, kind_heap) = contains_kind_ptr info_ptr kind kind_heap - | found - = (True, kind_heap) - = kinds_contains_kind_ptr info_ptr kinds kind_heap - kinds_contains_kind_ptr info_ptr [] kind_heap - = (False, kind_heap) unify_kinds kind k1=:(KI_Var info_ptr1) uni_info = unify_kinds k1 kind uni_info - unify_kinds kind1=:(KI_Arrow kinds1) kind2=:(KI_Arrow kinds2) uni_info=:{uki_error} - | length kinds1 == length kinds2 - = fold2St unifyKinds kinds1 kinds2 uni_info - = { uni_info & uki_error = kindError kind1 kind2 uki_error } + unify_kinds kind1=:(KI_Arrow x1 y1) kind2=:(KI_Arrow x2 y2) uni_info + = unifyKinds x1 x2 (unifyKinds y1 y2 uni_info) unify_kinds KI_Const KI_Const uni_info = uni_info unify_kinds kind1 kind2 uni_info=:{uki_error} = { uni_info & uki_error = kindError kind1 kind2 uki_error } -class toKindInfo a :: !a -> KindInfo - -instance toKindInfo TypeKind -where - toKindInfo (KindVar info_ptr) - = KI_Var info_ptr - toKindInfo KindConst - = KI_Const - toKindInfo (KindArrow ks) - = KI_Arrow [ toKindInfo k \\ k <- ks] -// ---> ("toKindInfo", arity) - +kindToKindInfo (KindVar info_ptr) + = KI_Var info_ptr +kindToKindInfo KindConst + = KI_Const +kindToKindInfo (KindArrow ks) + = kindArrowToKindInfo ks + +kindArrowToKindInfo [] + = KI_Const +kindArrowToKindInfo [k : ks] + = KI_Arrow (kindToKindInfo k) (kindArrowToKindInfo ks) + +kindInfoToKind kind_info kind_heap + # (kind_info, kind_heap) = skipIndirections kind_info kind_heap + = case kind_info of + KI_Arrow x y + # (x, kind_heap) = kindInfoToKind x kind_heap + # (y, kind_heap) = kindInfoToKind y kind_heap + -> case y of + KindArrow ks + -> (KindArrow [x:ks], kind_heap) + _ + -> (KindArrow [x], kind_heap) + _ + -> (KindConst, kind_heap) :: VarBind = { vb_var :: !KindInfoPtr @@ -306,9 +313,9 @@ where , con_var_binds :: ![VarBind] } -:: AnalState = +:: AnalyseState = { as_td_infos :: !.TypeDefInfos - , as_heaps :: !.TypeHeaps + , as_type_var_heap :: !.TypeVarHeap , as_kind_heap :: !.KindHeap , as_error :: !.ErrorAdmin } @@ -325,10 +332,13 @@ condCombineTypeProperties has_root_attr prop1 prop2 combineCoercionProperties prop1 prop2 :== (prop1 bitor prop2) bitand cIsNonCoercible combineHyperstrictness prop1 prop2 :== (prop1 bitand prop2) bitand cIsHyperStrict -class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalState) - -> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalState)) +class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalyseState) + -> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalyseState)) -cDummyBool :== False +freshKindVar kind_heap + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + # kind_var = KI_Var kind_info_ptr + = (kind_var, kind_heap <:= (kind_info_ptr, kind_var)) instance analTypes AType where @@ -340,14 +350,14 @@ where instance analTypes TypeVar where - analTypes has_root_attr modules form_tvs {tv_info_ptr} (conds=:{con_var_binds}, as=:{as_heaps, as_kind_heap}) - # (TVI_TypeKind kind_info_ptr, th_vars) = readPtr tv_info_ptr as_heaps.th_vars + analTypes has_root_attr modules form_tvs {tv_info_ptr} (conds=:{con_var_binds}, as=:{as_type_var_heap, as_kind_heap}) + # (TVI_TypeKind kind_info_ptr, as_type_var_heap) = readPtr tv_info_ptr as_type_var_heap (kind_info, as_kind_heap) = readPtr kind_info_ptr as_kind_heap (kind_info, as_kind_heap) = skipIndirections kind_info as_kind_heap | isEmpty form_tvs - = (kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) + = (kind_info, cIsHyperStrict, (conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap })) = (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] }, - { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })) + { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap })) instance analTypes Type where @@ -356,12 +366,14 @@ where 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] - kind = if (form_type_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- 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) + | 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) @@ -386,7 +398,7 @@ where = (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 (toKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error} + {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) @@ -402,40 +414,45 @@ where (combineCoercionProperties arg_type_props res_type_props) = (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as - # (type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as - (type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as - {uki_kind_heap, uki_error} = unifyKinds type_kind (KI_Arrow type_kinds) {uki_kind_heap = as_kind_heap, uki_error = as_error} + # (type_kind, cv_props, (conds, as)) = analTypes has_root_attr modules form_tvs tv conds_as + (kind_var, as_kind_heap) = freshKindVar as.as_kind_heap + (type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) + = check_type_list kind_var modules form_tvs types (conds, { as & as_kind_heap = as_kind_heap }) + {uki_kind_heap, uki_error} = unifyKinds type_kind type_kinds {uki_kind_heap = as_kind_heap, uki_error = as_error} type_props = if (is_non_coercible || has_root_attr) cIsNonCoercible (cv_props bitand cIsNonCoercible) - = (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) + = (kind_var, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })) where - check_type_list modules form_tvs [] conds_as - = ([], False, conds_as) - check_type_list modules form_tvs [type : types] conds_as - # (tk, 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 tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} - (tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }) - = ([tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as) - analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_heaps,as_kind_heap}) - # (th_vars, as_kind_heap) = new_local_kind_variables vars (as_heaps.th_vars, as_kind_heap) - = analTypes has_root_attr modules form_tvs type (conds, { as & as_heaps = { as_heaps & th_vars = th_vars}, as_kind_heap = as_kind_heap}) + check_type_list kind_var modules form_tvs [] conds_as + = (kind_var, False, conds_as) + check_type_list kind_var modules form_tvs [type : types] conds_as + # (tk, type_props, conds_as) = analTypes has_root_attr modules form_tvs type conds_as +// {uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + (tks, is_non_coercible, conds_as) = check_type_list kind_var modules form_tvs types conds_as + = (KI_Arrow tk tks, is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as) + analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_type_var_heap,as_kind_heap}) + # (as_type_var_heap, as_kind_heap) = new_local_kind_variables vars as_type_var_heap as_kind_heap + = analTypes has_root_attr modules form_tvs type (conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap}) where - new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap) - new_local_kind_variables td_args (type_var_heap, as_kind_heap) - = foldSt new_kind td_args (type_var_heap, as_kind_heap) + new_local_kind_variables :: [ATypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap) + new_local_kind_variables type_vars type_var_heap as_kind_heap + = foldSt new_kind type_vars (type_var_heap, as_kind_heap) where new_kind :: !ATypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap) - new_kind {atv_variable={tv_info_ptr},atv_attribute} (type_var_heap, kind_heap) + new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = ( type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) analTypes has_root_attr modules form_tvs type conds_as = (KI_Const, cIsHyperStrict, conds_as) -analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_heaps,as_kind_heap}) + +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, th_vars, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_heaps.th_vars, as_kind_heap) + (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 - (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }) + (conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap }) (other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as properties = combineTypeProperties cons_properties other_properties = (if coercible properties (properties bitor cIsNonCoercible), conds_as) @@ -473,6 +490,10 @@ where analTypesOfConstructor _ _ [] conds_as = (cIsHyperStrict, conds_as) +isATopConsVar cv :== cv < 0 +encodeTopConsVar cv :== dec (~cv) +decodeTopConsVar cv :== ~(inc cv) + emptyIdent name :== { id_name = name, id_info = nilPtr } newKindVariables td_args (type_var_heap, as_kind_heap) @@ -487,16 +508,16 @@ where is_abs (AbstractType _) = True is_abs _ = False -analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) -analyseTypeDefs modules groups type_def_infos heaps error - # as = { as_kind_heap = newHeap, as_heaps = heaps, as_td_infos = type_def_infos, as_error = error } - {as_td_infos,as_heaps,as_error} = foldSt (anal_type_defs_in_group modules) groups as - = check_left_root_attribution_of_typedefs modules groups as_td_infos as_heaps as_error +analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) +analyseTypeDefs modules groups type_def_infos type_var_heap error + # as = { as_kind_heap = newHeap, as_type_var_heap = type_var_heap, as_td_infos = type_def_infos, as_error = error } + {as_td_infos,as_type_var_heap,as_error} = foldSt (anal_type_defs_in_group modules) groups as + = check_left_root_attribution_of_typedefs modules groups as_td_infos as_type_var_heap as_error where - anal_type_defs_in_group modules group as=:{as_td_infos,as_heaps,as_kind_heap} - # (is_abstract_type, as_td_infos, as_heaps, as_kind_heap) - = foldSt (init_type_def_infos modules) group (False, as_td_infos, as_heaps, as_kind_heap) - as = { as & as_td_infos = as_td_infos, as_heaps = as_heaps, as_kind_heap = as_kind_heap } + anal_type_defs_in_group modules group as=:{as_td_infos,as_type_var_heap,as_kind_heap} + # (is_abstract_type, as_td_infos, as_type_var_heap, as_kind_heap) + = foldSt (init_type_def_infos modules) group (False, as_td_infos, as_type_var_heap, as_kind_heap) + as = { as & as_td_infos = as_td_infos, as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap } | is_abstract_type = as # (type_properties, conds, as) = foldSt (anal_type_def modules) group (cIsHyperStrict, { con_top_var_binds = [], con_var_binds = [] }, as) @@ -506,7 +527,7 @@ where (as_kind_heap, as_td_infos) = update_type_def_infos type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos = { as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos } - init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, type_heaps, kind_heap) + init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, as_type_var_heap, kind_heap) # {td_args,td_rhs} = modules.[gi_module].com_type_defs.[gi_index] = case td_rhs of AbstractType properties @@ -514,10 +535,10 @@ where new_tdi = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = properties bitor cIsAnalysed } - -> (True, { type_def_infos & [gi_module].[gi_index] = new_tdi}, type_heaps, kind_heap) + -> (True, { type_def_infos & [gi_module].[gi_index] = new_tdi}, as_type_var_heap, kind_heap) _ - # (tdi_kinds, (th_vars, kind_heap)) = newKindVariables td_args (type_heaps.th_vars, kind_heap) - -> (is_abstract_type, { type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds }, { type_heaps & th_vars = th_vars }, kind_heap) + # (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindVariables td_args (as_type_var_heap, kind_heap) + -> (is_abstract_type, { type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds }, as_type_var_heap, kind_heap) anal_type_def modules gi=:{gi_module,gi_index} (group_properties, conds, as=:{as_error}) # {com_type_defs,com_cons_defs} = modules.[gi_module] @@ -542,16 +563,7 @@ where where retrieve_kind (KindVar kind_info_ptr) kind_heap # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap - = determine_kind kind_info kind_heap - where - determine_kind kind kind_heap - # (kind, kind_heap) = skipIndirections kind kind_heap - = case kind of - KI_Arrow kinds - # (kinds, kind_heap) = mapSt determine_kind kinds kind_heap - -> (KindArrow kinds, kind_heap) - _ - -> (KindConst, kind_heap) + = kindInfoToKind kind_info kind_heap unify_var_binds :: ![VarBind] !*KindHeap -> *KindHeap unify_var_binds binds kind_heap @@ -625,11 +637,249 @@ where is_a_top_var var_number [] = False - check_left_root_attribution_of_typedefs modules groups type_def_infos type_heaps error - # (type_def_infos, th_vars, error) = foldSt (foldSt (checkLeftRootAttributionOfTypeDef modules)) groups (type_def_infos, type_heaps.th_vars, error) - = (type_def_infos, { type_heaps & th_vars = th_vars }, error) + check_left_root_attribution_of_typedefs modules groups type_def_infos type_var_heap error + # (type_def_infos, type_var_heap, error) = foldSt (foldSt (checkLeftRootAttributionOfTypeDef modules)) groups (type_def_infos, type_var_heap, error) + = (type_def_infos, type_var_heap, error) + +cDummyConditions =: { con_top_var_binds = [], con_var_binds = []} + +determineKind modules type as + # (type_kind, _, (_,as)) = analTypes cDummyBool modules [] type (cDummyConditions, as) + = (type_kind, as) + +determine_kinds_of_type_contexts :: !{#CommonDefs} ![TypeContext] !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState) +determine_kinds_of_type_contexts modules type_contexts class_infos as + = foldSt (determine_kinds_of_type_context modules) type_contexts (class_infos, as) +where + determine_kinds_of_type_context :: !{#CommonDefs} !TypeContext !(!*ClassDefInfos, !*AnalyseState) -> (!*ClassDefInfos, !*AnalyseState) + determine_kinds_of_type_context modules {tc_class={glob_module,glob_object={ds_ident,ds_index}},tc_types} (class_infos, as) +// # (class_kinds, class_infos) = myselect ds_ident class_infos glob_module ds_index + # (class_kinds, class_infos) = class_infos![glob_module,ds_index] + as = fold2St (verify_kind_of_type modules) class_kinds tc_types as + = (class_infos, as) + + verify_kind_of_type modules req_kind type as + # (kind_of_type, as=:{as_kind_heap,as_error}) = determineKind modules type as + {uki_kind_heap, uki_error} = unifyKinds kind_of_type (kindToKindInfo req_kind) {uki_kind_heap = as_kind_heap, uki_error = as_error} + = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } + +/* +import cheat + +myselect name array i j + # (copy, array) = uniqueCopy array + #! i_size = size copy + | i < i_size + #! j_size = size copy.[i] + | j < j_size + = array![i].[j] + = abort (("second index out of range " +++ toString j +++ ">=" +++ toString j_size) ---> ("myselect", name, i)) + = abort (("first index out of range " +++ toString i +++ ">=" +++ toString i_size) ---> ("myselect", name, j)) +*/ +determine_kinds_type_list :: !{#CommonDefs} [AType] !*AnalyseState -> *AnalyseState +determine_kinds_type_list modules types as + = foldSt (force_star_kind modules) types as +where + force_star_kind modules type as + # (off_kind, as=:{as_kind_heap,as_error}) = determineKind modules type as + {uki_kind_heap, uki_error} = unifyKinds off_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } +class_def_error = "cyclic dependencies between type classes" +type_appl_error = "type constructor has too many arguments" + +cyclicClassInfoMark =: [KindCycle] + +determineKindsOfClasses :: !NumberSet !{#CommonDefs} !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin + -> (!*ClassDefInfos, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) +determineKindsOfClasses used_module_numbers modules type_def_infos type_var_heap error + # nr_of_modules = size modules + class_infos = {{} \\ module_nr <- [0..nr_of_modules] } + class_infos = iFoldSt (initialyse_info_for_module used_module_numbers modules) 0 nr_of_modules class_infos + + as = + { as_td_infos = type_def_infos + , as_type_var_heap = type_var_heap + , as_kind_heap = newHeap + , as_error = error + } + + (class_infos, {as_td_infos,as_type_var_heap,as_error}) = iFoldSt (determine_kinds_of_class_in_module modules) 0 nr_of_modules (class_infos, as) + = (class_infos, as_td_infos, as_type_var_heap, as_error) +where + initialyse_info_for_module used_module_numbers modules module_index class_infos + | inNumberSet module_index used_module_numbers + # nr_of_classes = size modules.[module_index].com_class_defs + = { class_infos & [module_index] = createArray nr_of_classes [] } + = class_infos + + determine_kinds_of_class_in_module modules module_index (class_infos, as) + #! nr_of_classes = size class_infos.[module_index] + = iFoldSt (determine_kinds_of_class modules module_index) 0 nr_of_classes (class_infos, as) + + determine_kinds_of_class :: !{#CommonDefs} !Index !Index !(!*ClassDefInfos, !*AnalyseState) -> (!*ClassDefInfos, !*AnalyseState) + 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_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 + class_infos = { class_infos & [class_module,class_index] = cyclicClassInfoMark } + (class_infos, as) = foldSt (determine_kinds_of_context_class modules) class_context (class_infos, + { as & as_kind_heap = as_kind_heap, as_type_var_heap = as_type_var_heap, as_error = as_error }) + | as.as_error.ea_ok + # (class_infos, as) = determine_kinds_of_type_contexts modules class_context class_infos as + (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}) + = ({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 = modules.[class_module].com_class_defs.[class_index].class_name + = (class_infos, { as & as_error = checkError class_name class_def_error as.as_error }) + = (class_infos, as) + where + fresh_kind_vars nr_of_vars fresh_vars kind_heap + | nr_of_vars > 0 + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = fresh_kind_vars (dec nr_of_vars) [ kind_info_ptr : fresh_vars] (kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) + = (fresh_vars, kind_heap) + + determine_kinds_of_context_class modules {tc_class={glob_module,glob_object={ds_index}}} infos_and_as + = determine_kinds_of_class modules glob_module ds_index infos_and_as + + isCyclicClass [ KindCycle : _ ] = True + isCyclicClass _ = False + + bind_kind_vars type_vars kind_ptrs type_var_heap + = fold2St bind_kind_var type_vars kind_ptrs type_var_heap + where + bind_kind_var {tv_info_ptr} kind_info_ptr type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr) + + clear_variables type_vars type_var_heap + = foldSt clear_variable type_vars type_var_heap + where + clear_variable {tv_info_ptr} type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_Empty) + + determine_kinds_of_members modules members member_defs class_kind_vars (class_infos, as) + = iFoldSt (determine_kind_of_member modules members member_defs class_kind_vars) 0 (size members) (class_infos, as) + + determine_kind_of_member modules members member_defs class_kind_vars loc_member_index (class_infos, as) + # glob_member_index = members.[loc_member_index].ds_index + {me_class_vars,me_type={st_vars,st_args,st_result,st_context}} = member_defs.[glob_member_index] + as_type_var_heap = clear_variables st_vars as.as_type_var_heap + as_type_var_heap = bind_kind_vars me_class_vars class_kind_vars as_type_var_heap + (as_type_var_heap, as_kind_heap) = fresh_kind_vars_for_unbound_vars st_vars as_type_var_heap as.as_kind_heap + as = determine_kinds_type_list modules [st_result:st_args] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} + (class_infos, as) = determine_kinds_of_type_contexts modules (tl st_context) class_infos as + = (class_infos, as) + where + fresh_kind_vars_for_unbound_vars type_vars type_var_heap kind_heap + = foldSt fresh_kind_vars_for_unbound_var type_vars (type_var_heap, kind_heap) + + fresh_kind_vars_for_unbound_var {tv_info_ptr} (type_var_heap, kind_heap) + # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + = case tv_info of + TVI_Empty + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + -> (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) + _ + -> (type_var_heap, kind_heap) + + retrieve_class_kinds class_kind_vars kind_heap + = mapSt retrieve_kind class_kind_vars kind_heap + where + retrieve_kind kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap + = kindInfoToKind kind_info kind_heap + +bindFreshKindVariablesToTypeVars :: [TypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap) +bindFreshKindVariablesToTypeVars type_vars type_var_heap as_kind_heap + = foldSt new_kind type_vars (type_var_heap, as_kind_heap) +where + new_kind :: !TypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap) + new_kind {tv_info_ptr} (type_var_heap, kind_heap) + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = ( type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) + +checkKindsOfCommonDefsAndFunctions :: !Index !Index !NumberSet !IndexRange !{#CommonDefs} !u:{# FunDef} !v:{#DclModule} !*TypeDefInfos !*ClassDefInfos + !*TypeVarHeap !*ErrorAdmin -> (!u:{# FunDef}, !v:{#DclModule}, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) +checkKindsOfCommonDefsAndFunctions first_uncached_module main_module_index used_module_numbers icl_fun_def_range common_defs icl_fun_defs dcl_modules + type_def_infos class_infos type_var_heap error + # as = + { as_td_infos = type_def_infos + , as_type_var_heap = type_var_heap + , as_kind_heap = newHeap + , as_error = error + } + + # (icl_fun_defs, dcl_modules, class_infos, as) + = iFoldSt (check_kinds_of_module first_uncached_module main_module_index used_module_numbers icl_fun_def_range common_defs) + 0 (size common_defs) (icl_fun_defs, dcl_modules, class_infos, as) + = (icl_fun_defs, dcl_modules, as.as_td_infos, as.as_type_var_heap, as.as_error) +where + check_kinds_of_module first_uncached_module main_module_index used_module_numbers {ir_from,ir_to} common_defs module_index + (icl_fun_defs, dcl_modules, class_infos, as) + | inNumberSet module_index used_module_numbers + | module_index == main_module_index + # (class_infos, as) = check_kinds_of_class_instances common_defs 0 common_defs.[module_index].com_instance_defs class_infos as + (icl_fun_defs, class_infos, as) = iFoldSt (check_kinds_of_icl_fuction common_defs) ir_from ir_to (icl_fun_defs, class_infos, as) + = (icl_fun_defs, dcl_modules, class_infos, as) + | module_index >= first_uncached_module + # (class_infos, as) = check_kinds_of_class_instances common_defs 0 common_defs.[module_index].com_instance_defs class_infos as + # (dcl_modules, class_infos, as) = check_kinds_of_dcl_fuctions common_defs module_index dcl_modules class_infos as + = (icl_fun_defs, dcl_modules, class_infos, as) + = (icl_fun_defs, dcl_modules, class_infos, as) + = (icl_fun_defs, dcl_modules, class_infos, as) + + check_kinds_of_class_instances common_defs instance_index instance_defs class_infos as + | instance_index == size instance_defs + = (class_infos, as) + # (class_infos, as) = check_kinds_of_class_instance common_defs instance_defs.[instance_index] class_infos as + = check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as + where + check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState) + check_kinds_of_class_instance common_defs {ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos + as=:{as_type_var_heap,as_kind_heap,as_error} + # as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error + (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap + as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error } + (class_infos, as) = determine_kinds_of_type_contexts common_defs + [{tc_class = ins_class, tc_types = it_types, tc_var = nilPtr} : it_context] class_infos as + = (class_infos, { as & as_error = popErrorAdmin as.as_error}) + + check_kinds_of_icl_fuction common_defs fun_index (icl_fun_defs, class_infos, as) + # ({fun_type,fun_symb,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index] + = case fun_type of + Yes symbol_type + # as_error = pushErrorAdmin (newPosition fun_symb 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, { as & as_error = popErrorAdmin as.as_error }) + No + -> (icl_fun_defs, class_infos, as) + + check_kinds_of_dcl_fuctions common_defs module_index dcl_modules class_infos as + # ({dcl_functions,dcl_instances}, dcl_modules) = dcl_modules![module_index] + # nr_of_dcl_funs = dcl_instances.ir_from + # (class_infos, as) = iFoldSt (check_kinds_of_dcl_fuction common_defs dcl_functions) 0 nr_of_dcl_funs (class_infos, as) + = (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 + (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}) + + check_kinds_of_symbol_type :: !{#CommonDefs} !SymbolType !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState) + check_kinds_of_symbol_type common_defs {st_vars,st_result,st_args,st_context} class_infos as=:{as_type_var_heap,as_kind_heap} + # (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars st_vars as_type_var_heap as_kind_heap + as = determine_kinds_type_list common_defs [st_result:st_args] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} + = determine_kinds_of_type_contexts common_defs st_context class_infos as + instance <<< DynamicType where (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type diff --git a/frontend/check.icl b/frontend/check.icl index c67deb5..3c8cf6b 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -903,16 +903,17 @@ checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs (size_com_selector_defs,com_selector_defs) = usize com_selector_defs (size_com_cons_defs,com_cons_defs) = usize com_cons_defs - (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs) + (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs_symbol_table) = createClassDictionaries module_index com_class_defs modules size_com_type_defs size_com_selector_defs size_com_cons_defs - type_heaps.th_vars var_heap cs + type_heaps.th_vars var_heap cs.cs_symbol_table com_type_defs = array_plus_list com_type_defs new_type_defs com_selector_defs = array_plus_list com_selector_defs new_selector_defs com_cons_defs = array_plus_list com_cons_defs new_cons_defs = ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs, - com_member_defs = com_member_defs, com_instance_defs = com_instance_defs, /* AA */ com_generic_defs = com_generic_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs) + com_member_defs = com_member_defs, com_instance_defs = com_instance_defs, /* AA */ com_generic_defs = com_generic_defs }, modules, + { type_heaps & th_vars = th_vars }, var_heap, { cs & cs_symbol_table = cs_symbol_table }) collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) -> (!*{# Int}, ![Declaration]) collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics} diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl index e035f29..a6e63e7 100644 --- a/frontend/checktypes.dcl +++ b/frontend/checktypes.dcl @@ -20,17 +20,7 @@ checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{ checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) -createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState - -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) -/* -bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; -clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; -*/ -isATopConsVar cv :== cv < 0 -encodeTopConsVar cv :== dec (~cv) -decodeTopConsVar cv :== ~(inc cv) -/* -expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin - -> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin) -*/ +createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*SymbolTable + -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*SymbolTable) + removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index a43e1d4..1780233 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -174,10 +174,6 @@ addToAttributeEnviron _ _ attr_env error emptyIdent name :== { id_name = name, id_info = nilPtr } -isATopConsVar cv :== cv < 0 -encodeTopConsVar cv :== dec (~cv) -decodeTopConsVar cv :== ~(inc cv) - checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} # (type_def, ts_type_defs) = ts_type_defs![type_index] @@ -1161,18 +1157,15 @@ removeVariablesFromSymbolTable scope vars symbol_table makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type } -createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState - -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) -createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap cs - | cs.cs_error.ea_ok - - # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules [] - { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs - (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table) - = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table }) - = (class_defs, modules, [], [], [], type_var_heap, var_heap, cs) -where - +createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*SymbolTable + -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*SymbolTable) +createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap symbol_table + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, symbol_table) + = create_class_dictionaries mod_index 0 class_defs modules [] + { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap symbol_table + (type_defs, sel_defs, cons_defs, symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], symbol_table) + = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, symbol_table) +where collect_type_def type_ptr (type_defs, sel_defs, cons_defs, symbol_table) # ({ ste_kind = STE_DictType type_def }, symbol_table) = readPtr type_ptr symbol_table (RecordType {rt_constructor, rt_fields}) = type_def.td_rhs @@ -1194,91 +1187,71 @@ where = create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) - create_class_dictionary :: !Index !Index !*{#ClassDef} !w:{#DclModule} !v:[SymbolPtr] !u:Indexes !*TypeVarHeap !*VarHeap !*CheckState - -> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*CheckState) + create_class_dictionary :: !Index !Index !*{#ClassDef} !w:{#DclModule} !v:[SymbolPtr] !u:Indexes !*TypeVarHeap !*VarHeap !*SymbolTable + -> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*SymbolTable) create_class_dictionary mod_index class_index class_defs =:{[class_index] = class_def } modules rev_dictionary_list - indexes type_var_heap var_heap cs=:{cs_symbol_table,cs_error} + indexes type_var_heap var_heap symbol_table # {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_name,id_info}}} = class_def - | isNilPtr id_info - # (type_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table - nr_of_members = size class_members - nr_of_fields = nr_of_members + length class_context - rec_type_id = { class_name & id_info = type_id_info} - class_dictionary = { ds & ds_ident = rec_type_id } - class_defs = { class_defs & [class_index] = { class_def & class_dictionary = class_dictionary}} - (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) - = create_class_dictionaries_of_contexts mod_index class_context class_defs modules - rev_dictionary_list indexes type_var_heap var_heap { cs & cs_symbol_table = cs_symbol_table } - - { index_type, index_cons, index_selector } = indexes - - type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity - - rec_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]]) - field_type = makeAttributedType TA_Multi AN_None TE - - (rev_fields, var_heap, cs_symbol_table) - = build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap cs.cs_symbol_table - (index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, cs_symbol_table) - = build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields - [ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap cs_symbol_table - - (cons_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table - rec_cons_id = { class_name & id_info = cons_id_info} - cons_symbol = { ds_ident = rec_cons_id, ds_arity = nr_of_fields, ds_index = index_cons } - (cons_type_ptr, var_heap) = newPtr VI_Empty var_heap - - (td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap - - - type_def = - { td_name = rec_type_id - , td_index = index_type - , td_arity = 0 - , td_args = td_args - , td_attrs = [] - , td_context = [] - , td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }} - , td_attribute = TA_None - , td_pos = NoPos - , td_used_types = [] - } - - cons_def = - { cons_symb = rec_cons_id - , cons_type = { st_vars = [], st_args = reverse rev_field_types, st_result = rec_type, - st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] } - , cons_priority = NoPrio - , cons_index = 0 - , cons_type_index = index_type - , cons_exi_vars = [] - , cons_arg_vars = [] - , cons_type_ptr = cons_type_ptr - , cons_pos = NoPos - } - = ({ class_defs & [class_index] = { class_def & class_dictionary = { class_dictionary & ds_index = index_type }}}, modules, - [ type_id_info : rev_dictionary_list ], { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector }, - type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table - <:= (type_id_info, { ste_kind = STE_DictType type_def, ste_index = index_type, - ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" }) - <:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons, - ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })}) - - # ({ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table - | ste_kind == STE_Empty - = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError class_name "cyclic dependencies between type classes" cs_error}) - = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table }) - - create_class_dictionaries_of_contexts mod_index [{tc_class = {glob_module, glob_object={ds_index}}}:tcs] class_defs modules - rev_dictionary_list indexes type_var_heap var_heap cs - | mod_index == glob_module - # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) - = create_class_dictionary mod_index ds_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs - = create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs - = create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs - create_class_dictionaries_of_contexts mod_index [] class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs - = (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) + # (type_id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table + nr_of_members = size class_members + nr_of_fields = nr_of_members + length class_context + rec_type_id = { class_name & id_info = type_id_info} + class_dictionary = { ds & ds_ident = rec_type_id } + + { index_type, index_cons, index_selector } = indexes + + type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity + + rec_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]]) + field_type = makeAttributedType TA_Multi AN_None TE + + (rev_fields, var_heap, symbol_table) + = build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap symbol_table + (index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, symbol_table) + = build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields + [ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap symbol_table + + (cons_id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table + rec_cons_id = { class_name & id_info = cons_id_info} + cons_symbol = { ds_ident = rec_cons_id, ds_arity = nr_of_fields, ds_index = index_cons } + (cons_type_ptr, var_heap) = newPtr VI_Empty var_heap + + (td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap + + + type_def = + { td_name = rec_type_id + , td_index = index_type + , td_arity = 0 + , td_args = td_args + , td_attrs = [] + , td_context = [] + , td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }} + , td_attribute = TA_None + , td_pos = NoPos + , td_used_types = [] + } + + cons_def = + { cons_symb = rec_cons_id + , cons_type = { st_vars = [], st_args = reverse rev_field_types, st_result = rec_type, + st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] } + , cons_priority = NoPrio + , cons_index = 0 + , cons_type_index = index_type + , cons_exi_vars = [] + , cons_arg_vars = [] + , cons_type_ptr = cons_type_ptr + , cons_pos = NoPos + } + + = ({ class_defs & [class_index] = { class_def & class_dictionary = { class_dictionary & ds_index = index_type }}}, modules, + [ type_id_info : rev_dictionary_list ], { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector }, + type_var_heap, var_heap, + symbol_table <:= (type_id_info, { ste_kind = STE_DictType type_def, ste_index = index_type, + ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" }) + <:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons, + ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })) new_attributed_type_variable tv type_var_heap # (new_tv_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap @@ -1313,7 +1286,6 @@ where , sd_type = { st_vars = [], st_args = [ rec_type ], st_result = field_type, st_arity = 1, st_context = [], st_attr_vars = [], st_attr_env = [] } , sd_exi_vars = [] -// , sd_exi_attrs = [] , sd_field_nr = field_nr , sd_type_index = rec_type_index , sd_type_ptr = sd_type_ptr diff --git a/frontend/frontend.icl b/frontend/frontend.icl index c47db55..6cc0cef 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -4,7 +4,7 @@ implementation module frontend import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics, - convertimportedtypes, checkKindCorrectness, compilerSwitches, analtypes, generics + convertimportedtypes, /*checkKindCorrectness, */ compilerSwitches, analtypes, generics SwitchGenerics on off :== off @@ -80,12 +80,12 @@ frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macr },cached_functions_and_macros,cached_dcl_mods,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps ) -//import StdDebug +// import StdDebug frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File (!Optional !*File) !*Heaps -> ( !Optional *FrontEndSyntaxTree,!*{# FunDef },!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) frontEndInterface options mod_ident search_paths cached_dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out tcl_file heaps - // # files = trace_n ("Compiling "+++mod_ident.id_name) files +// # files = trace_n ("Compiling "+++mod_ident.id_name) files # (ok, mod, hash_table, error, predef_symbols, files) = wantModule cWantIclFile mod_ident NoPos options.feo_generics(hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols files @@ -147,9 +147,18 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an # (type_groups, ti_common_defs, td_infos, icl_common, dcl_mods, type_heaps, error_admin) = partionateAndExpandTypes icl_used_module_numbers main_dcl_module_n icl_common dcl_mods type_heaps error_admin ti_common_defs = { ti_common_defs & [main_dcl_module_n] = icl_common } - # (td_infos, type_heaps, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps error_admin + # (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps.th_vars error_admin +/* (fun_defs, dcl_mods, th_vars, td_infos, error_admin) = checkKindCorrectness main_dcl_module_n nr_of_chached_functions_and_macros icl_instances ti_common_defs n_cached_dcl_modules fun_defs dcl_mods type_heaps.th_vars td_infos error_admin +*/ + (class_infos, td_infos, th_vars, error_admin) + = determineKindsOfClasses icl_used_module_numbers ti_common_defs td_infos th_vars error_admin + #! nr_of_icl_functions = icl_mod.icl_instances.ir_from + # (fun_defs, dcl_mods, td_infos, th_vars, error_admin) + = checkKindsOfCommonDefsAndFunctions n_cached_dcl_modules main_dcl_module_n icl_used_module_numbers global_fun_range + ti_common_defs fun_defs dcl_mods td_infos class_infos th_vars error_admin + type_heaps = { type_heaps & th_vars = th_vars } # heaps = { heaps & hp_type_heaps = type_heaps } # (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common diff --git a/frontend/generics.icl b/frontend/generics.icl index 014d7ef..ffbfe14 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -232,18 +232,17 @@ convertGenerics } } - #! (gs_dcl_modules, gs_modules, gs_heaps, cs) = - create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs + #! (gs_dcl_modules, gs_modules, gs_heaps, cs_symbol_table) = + create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs.cs_symbol_table // create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs //---> "*** create class dictionaries" - # {cs_symbol_table, cs_predef_symbols, cs_error} = cs # hash_table = { hash_table & hte_symbol_heap = cs_symbol_table } #! index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun} = ( gs_groups, gs_modules, gs_fun_defs, index_range, gs_td_infos, gs_heaps, hash_table, - cs_predef_symbols, gs_dcl_modules, gs_opt_dcl_icl_conversions, cs_error) + cs.cs_predef_symbols, gs_dcl_modules, gs_opt_dcl_icl_conversions, cs.cs_error) where return { gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos, gs_heaps, gs_main_dcl_module_n, gs_dcl_modules, gs_opt_dcl_icl_conversions, gs_error} @@ -252,21 +251,21 @@ where gs_td_infos, gs_heaps, hash_table, predefs, gs_dcl_modules, gs_opt_dcl_icl_conversions, gs_error) - create_class_dictionaries module_index dcl_modules modules heaps cs + create_class_dictionaries module_index dcl_modules modules heaps symbol_table #! size_of_modules = size modules | module_index == size_of_modules - = (dcl_modules, modules, heaps, cs) - #! (dcl_modules, modules, heaps, cs) = - create_class_dictionaries1 module_index dcl_modules modules heaps cs - = create_class_dictionaries (inc module_index) dcl_modules modules heaps cs + = (dcl_modules, modules, heaps, symbol_table) + #! (dcl_modules, modules, heaps, symbol_table) = + create_class_dictionaries1 module_index dcl_modules modules heaps symbol_table + = create_class_dictionaries (inc module_index) dcl_modules modules heaps symbol_table create_class_dictionaries1 module_index dcl_modules modules heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap} - cs + symbol_table #! (common_defs, modules) = modules![module_index] #! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy - #! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, cs) = + #! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, symbol_table) = createClassDictionaries module_index class_defs @@ -274,7 +273,7 @@ where (size common_defs.com_type_defs) (size common_defs.com_selector_defs) (size common_defs.com_cons_defs) - th_vars hp_var_heap cs + th_vars hp_var_heap symbol_table #! common_defs = { common_defs & com_class_defs = class_defs, @@ -284,7 +283,7 @@ where #! heaps = {heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} #! modules = { modules & [module_index] = common_defs } - = (dcl_modules, modules, heaps, cs) + = (dcl_modules, modules, heaps, symbol_table) convertInstances :: !*GenericState -> (![Global Index], !*GenericState) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index e3be8f8..928c2d5 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -255,6 +255,8 @@ cNameLocationDependent :== True , class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase } +:: ClassDefInfos :== {# .{! [TypeKind]}} + :: MemberDef = { me_symb :: !Ident , me_class :: !Global Index @@ -858,7 +860,7 @@ cNonRecursiveAppl :== False :: KindInfoPtr :== Ptr KindInfo :: KindInfo = KI_Var !KindInfoPtr - | KI_Arrow ![KindInfo] + | KI_Arrow !KindInfo !KindInfo | KI_Const | KI_ConsVar @@ -932,7 +934,7 @@ cNonRecursiveAppl :== False :: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String -:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] +:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] | KindCycle instance toString TypeKind instance <<< TypeKind diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ed5461d..a7335f2 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -247,6 +247,8 @@ cNameLocationDependent :== True , class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase } +:: ClassDefInfos :== {# .{! [TypeKind]}} + :: MemberDef = { me_symb :: !Ident , me_class :: !Global Index @@ -839,7 +841,7 @@ cNotVarNumber :== -1 :: KindInfoPtr :== Ptr KindInfo :: KindInfo = KI_Var !KindInfoPtr - | KI_Arrow ![KindInfo] + | KI_Arrow !KindInfo !KindInfo | KI_Const | KI_ConsVar @@ -917,8 +919,7 @@ cNotVarNumber :== -1 :: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String -//:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow !Int -:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] +:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] | KindCycle :: Occurrence = { occ_ref_count :: !ReferenceCount @@ -935,7 +936,6 @@ cNotVarNumber :== -1 :: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression | OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding -// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences :: TypeDefInfo = { tdi_kinds :: ![TypeKind] @@ -1798,14 +1798,12 @@ where instance toString KindInfo where - toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr) - toString (KI_Const) = "*" - toString (KI_Arrow kinds) = kind_list_to_string kinds + toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr) + toString (KI_Const) = "*" + toString (KI_Arrow kind1 kind2) = withBrackets kind1 (toString kind1) +++ " -> " +++ toString kind2 where - kind_list_to_string [] = " ?????? " - kind_list_to_string [k] = "* -> *" - kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks - + withBrackets (KI_Arrow _ _) kind_str = "(" +++ kind_str +++ ")" + withBrackets _ kind_str = kind_str instance <<< TypeDefInfo where |