diff options
| -rw-r--r-- | backend/Windows/Clean System Files/backend_library | 1 | ||||
| -rw-r--r-- | backend/backend.dcl | 2 | ||||
| -rw-r--r-- | backend/backend.icl | 6 | ||||
| -rw-r--r-- | backend/backendconvert.icl | 16 | ||||
| -rw-r--r-- | frontend/analtypes.icl | 51 | ||||
| -rw-r--r-- | frontend/analunitypes.icl | 8 | ||||
| -rw-r--r-- | frontend/check.icl | 28 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 145 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 1 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 58 | ||||
| -rw-r--r-- | frontend/classify.icl | 20 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 12 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 4 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 2 | ||||
| -rw-r--r-- | frontend/generics1.icl | 51 | ||||
| -rw-r--r-- | frontend/hashtable.dcl | 1 | ||||
| -rw-r--r-- | frontend/hashtable.icl | 3 | ||||
| -rw-r--r-- | frontend/mergecases.icl | 8 | ||||
| -rw-r--r-- | frontend/parse.icl | 35 | ||||
| -rw-r--r-- | frontend/postparse.icl | 14 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 24 | ||||
| -rw-r--r-- | frontend/type.icl | 115 |
22 files changed, 445 insertions, 160 deletions
diff --git a/backend/Windows/Clean System Files/backend_library b/backend/Windows/Clean System Files/backend_library index 9e7fbc5..04493a1 100644 --- a/backend/Windows/Clean System Files/backend_library +++ b/backend/Windows/Clean System Files/backend_library @@ -85,6 +85,7 @@ BETypes BENoTypes BEFlatType BEAlgebraicType +BEExtendableAlgebraicType BERecordType BEAbsType BEConstructors diff --git a/backend/backend.dcl b/backend/backend.dcl index cfc7b1b..d9f959f 100644 --- a/backend/backend.dcl +++ b/backend/backend.dcl @@ -205,6 +205,8 @@ BEFlatType :: !BESymbolP !BEAttribution !BETypeVarListP !BackEnd -> (!BEFlatType // BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution,BETypeVarListP arguments); BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; // void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); +BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; +// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd; // void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields); BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd; diff --git a/backend/backend.icl b/backend/backend.icl index ef0fe09..6161bcb 100644 --- a/backend/backend.icl +++ b/backend/backend.icl @@ -550,6 +550,12 @@ BEAlgebraicType a0 a1 a2 = code { } // void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); +BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; +BEExtendableAlgebraicType a0 a1 a2 = code { + ccall BEExtendableAlgebraicType "pp:V:p" +} +// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); + BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd; BERecordType a0 a1 a2 a3 a4 a5 = code { ccall BERecordType "IppIp:V:p" diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index 6ea31f1..aea02aa 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -819,11 +819,9 @@ convertTypeVar typeVar defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be - # (flatType, be) - = convertTypeLhs moduleIndex typeIndex td_attribute td_args be - # (constructors, be) - = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be - = appBackEnd (BEAlgebraicType flatType constructors) be + # (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be + # (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be + = appBackEnd (BEAlgebraicType flatType constructors) be defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} be # constructorIndex = rt_constructor.ds_index constructorDef = constructors.[constructorIndex] @@ -854,6 +852,14 @@ defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType = beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} be = beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be +defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtendableAlgType constructorSymbols} be + # (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be + # (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be + = appBackEnd (BEExtendableAlgebraicType flatType constructors) be +defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} be + # (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be + # (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be + = appBackEnd (BEExtendableAlgebraicType flatType constructors) be defineType _ _ _ _ _ be = be diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 639db53..b7de966 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -619,9 +619,9 @@ where (kinds_in_group, (as_kind_heap, as_td_infos)) = mapSt determine_kinds group (as.as_kind_heap, as.as_td_infos) as_kind_heap = unify_var_binds conds.con_var_binds as_kind_heap (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars conds.con_top_var_binds 0 as_kind_heap - (as_kind_heap, as_td_infos) - = update_type_def_infos modules 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 + (as_kind_heap, as_td_infos, as_error) + = update_type_def_infos modules type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos as.as_error + as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos, as_error = as_error = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, as_type_var_heap, kind_heap) @@ -633,6 +633,12 @@ where AbstractSynType properties _ # type_def_infos = init_abstract_type_def properties td_args gi_module gi_index type_def_infos -> (True, type_def_infos, as_type_var_heap, kind_heap) + ExtendableAlgType _ + # (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindConstVariables 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) + AlgConses _ _ + # (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindConstVariables 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) _ # (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) @@ -652,6 +658,14 @@ where # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))) + newKindConstVariables td_args (type_var_heap, as_kind_heap) + = mapSt new_kind_const td_args (type_var_heap, as_kind_heap) + where + new_kind_const :: ATypeVar *(*TypeVarHeap,*KindHeap) -> (!TypeKind,!(!*TypeVarHeap,!*KindHeap)); + new_kind_const {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = (KindVar kind_info_ptr, (writePtr tv_info_ptr (TVI_TypeKind kind_info_ptr) 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] {td_ident,td_pos,td_args,td_rhs} = com_type_defs.[gi_index] @@ -669,6 +683,12 @@ where = (cv_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error})) anal_rhs_of_type_def modules com_cons_defs (NewType cons) conds_as = analTypesOfConstructor modules com_cons_defs cons conds_as + anal_rhs_of_type_def modules com_cons_defs (ExtendableAlgType conses) conds_as + # (cons_properties, (conds,as)) = analTypesOfConstructors modules com_cons_defs conses conds_as + = ((cons_properties bitand (bitnot cIsHyperStrict)) /*bitor cIsNonCoercible*/, (conds,as)) + anal_rhs_of_type_def modules com_cons_defs (AlgConses conses _) conds_as + # (cons_properties, (conds,as)) = analTypesOfConstructors modules com_cons_defs conses conds_as + = ((cons_properties bitand (bitnot cIsHyperStrict)) /*bitor cIsNonCoercible*/, (conds,as)) determine_kinds {gi_module,gi_index} (kind_heap, td_infos) # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module,gi_index] @@ -721,17 +741,24 @@ where # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = normalize_var kind_info_ptr kind_info (kind_store, kind_heap) - update_type_def_infos modules type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos - # (_,as_kind_heap,as_td_infos) = fold2St (update_type_def_info modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store, kind_heap, td_infos) - = (as_kind_heap,as_td_infos) + update_type_def_infos modules type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos error + # (_,as_kind_heap,as_td_infos,error) + = fold2St (update_type_def_info modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store,kind_heap,td_infos,error) + = (as_kind_heap,as_td_infos,error) where update_type_def_info modules type_properties top_vars {gi_module,gi_index} updated_kinds - (kind_store,kind_heap,td_infos) + (kind_store,kind_heap,td_infos,error) # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds updated_kinds top_vars kind_store kind_heap # td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars #! td_infos & [gi_module,gi_index] = td_info - = (kind_store, kind_heap, td_infos) + | type_properties bitand cIsNonCoercible<>0 + # type_def = modules.[gi_module].com_type_defs.[gi_index] + | not (isUniqueAttr type_def.td_attribute) && is_ExtendableAlgType_or_AlgConses type_def.td_rhs + # error = checkErrorWithPosition type_def.td_ident type_def.td_pos "a non unique extendable algebraic data type must be coercible" error + = (kind_store, kind_heap, td_infos, error) + = (kind_store, kind_heap, td_infos, error) + = (kind_store, kind_heap, td_infos, error) determine_type_def_info [KindVar kind_info_ptr : kind_vars] [kind : kinds] top_vars kind_store kind_heap # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap @@ -752,6 +779,10 @@ where is_a_top_var var_number [] = False + is_ExtendableAlgType_or_AlgConses (ExtendableAlgType _) = True + is_ExtendableAlgType_or_AlgConses (AlgConses _ _) = True + is_ExtendableAlgType_or_AlgConses _ = False + check_dcl_properties modules dcl_types dcl_mod_index properties {gi_module, gi_index} as | gi_module == dcl_mod_index && gi_index < size dcl_types # {td_ident, td_rhs, td_args, td_pos} = dcl_types.[gi_index] @@ -1166,6 +1197,10 @@ isUniqueTypeRhs common_defs mod_index (RecordType {rt_constructor={ds_index}}) s = constructor_is_unique mod_index ds_index common_defs state isUniqueTypeRhs common_defs mod_index (NewType {ds_index}) state = constructor_is_unique mod_index ds_index common_defs state +isUniqueTypeRhs common_defs mod_index (ExtendableAlgType constructors) state + = has_unique_constructor constructors common_defs mod_index state +isUniqueTypeRhs common_defs mod_index (AlgConses constructors _) state + = has_unique_constructor constructors common_defs mod_index state isUniqueTypeRhs common_defs mod_index _ state = (False, state) diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index ee086b5..0758414 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -196,6 +196,10 @@ where | properties bitand cIsNonCoercible == 0 = (PostiveSignClass, scs) = (TopSignClass, scs) + sign_class_of_type_def module_index (ExtendableAlgType conses) group_nr ci scs + = (TopSignClass, scs) + sign_class_of_type_def module_index (AlgConses conses _) group_nr ci scs + = (TopSignClass, scs) sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class scs #! cons_def = ci.[module_index].com_cons_defs.[ds_index] @@ -473,6 +477,10 @@ where = (PropClass, pcs) prop_class_of_type_def _ (AbstractSynType properties _) _ _ pcs = (PropClass, pcs) + prop_class_of_type_def module_index (ExtendableAlgType conses) group_nr ci pcs + = (PropClass, pcs) + prop_class_of_type_def module_index (AlgConses conses _) group_nr ci pcs + = (PropClass, pcs) prop_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_prop_class pcs #! cons_def = ci.[module_index].com_cons_defs.[ds_index] diff --git a/frontend/check.icl b/frontend/check.icl index 6ebb935..52fafe3 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -951,6 +951,8 @@ collectCommonDefinitions {def_types,def_constructors,def_selectors,def_classes,d sizes = { sizes & [cGenericCaseDefs] = size } = (sizes, defs) where + type_def_to_dcl {td_rhs=UncheckedAlgConses type_ext_ident _, td_ident, td_pos} (decl_index, decls) + = (inc decl_index, [Declaration {decl_ident = type_ext_ident, decl_pos = td_pos, decl_kind = STE_TypeExtension, decl_index = decl_index} : decls]) type_def_to_dcl {td_ident, td_pos} (decl_index, decls) = (inc decl_index, [Declaration {decl_ident = td_ident, decl_pos = td_pos, decl_kind = STE_Type, decl_index = decl_index} : decls]) @@ -1187,6 +1189,20 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz = { td & td_rhs = NewType {cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} } renumber_type_def td = td + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_TypeExtension, decl_index}) cdefs + # (type_def,cdefs) = cdefs!com_type_defs.[decl_index] + # type_def = renumber_type_extension_def type_def + # cdefs={cdefs & com_type_defs.[decl_index]=type_def} + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cTypeDefs,decl_index]},cdefs) + where + renumber_type_extension_def td=:{td_rhs = UncheckedAlgConses type_ext_ident conses} + # conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses] + = {td & td_rhs = UncheckedAlgConses type_ext_ident conses} + renumber_type_extension_def td=:{td_rhs = AlgConses conses type_ext_ident} + # conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses] + = {td & td_rhs = AlgConses conses type_ext_ident} + renumber_type_extension_def td + = td renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cConstructorDefs,decl_index]},cdefs) renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Field _, decl_index}) cdefs @@ -1407,6 +1423,18 @@ where # (cop_td_indexes, cop_cd_indexes, cop_gd_indexes) = copied_defs # copied_defs = (cop_td_indexes, cop_cd_indexes, [decl_index:cop_gd_indexes]) = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, [generic_def:new_generic_defs], copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs) + add_dcl_definition {com_type_defs,com_cons_defs} dcl=:(Declaration {decl_kind = STE_TypeExtension, decl_index}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, (cop_td_indexes, cop_cd_indexes, cop_gd_indexes), conversion_table, icl_sizes, icl_decl_symbols, cs) + # type_def = com_type_defs.[decl_index] + (new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) = add_type_def type_def new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs + cop_td_indexes = [decl_index : cop_td_indexes] + = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, (cop_td_indexes, cop_cd_indexes, cop_gd_indexes), conversion_table, icl_sizes, icl_decl_symbols, cs) + where + add_type_def td=:{td_pos, td_rhs = UncheckedAlgConses type_ext_ident conses} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs + # (conses,(new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)) = copy_and_redirect_cons_symbols com_cons_defs td_pos conses (new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) + = ([{ td & td_rhs = UncheckedAlgConses type_ext_ident conses} : new_type_defs],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) + add_type_def td new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs + = ([td : new_type_defs],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) add_dcl_definition _ _ result = result copy_and_redirect_cons_symbols com_cons_defs td_pos [cons:conses] (new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 83fc6f2..91f1af8 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -260,15 +260,14 @@ where let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, pattern_position, var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr pattern_position + transform_pattern_into_cases (AP_Algebraic cons_symbol global_type_index args opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr pattern_position var_store expr_heap opt_dynamics cs - type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position }] - # (case_guards,expr_heap,cs) = make_case_guards cons_symbol type_symbol alg_patterns expr_heap cs + # (case_guards,expr_heap,cs) = make_case_guards cons_symbol global_type_index alg_patterns expr_heap cs = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, @@ -286,7 +285,7 @@ where var_store expr_heap opt_dynamics cs # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern arg result_expr pattern_position var_store expr_heap opt_dynamics cs - type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} + type_symbol = {gi_module = cons_symbol.glob_module, gi_index = type_index} (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pattern_position }] @@ -886,8 +885,8 @@ checkExpression free_vars (PE_Matches case_ident expr pattern position) e_input= = checkPattern pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], []) ps e_info cs | is_single_constructor_pattern pattern = case pattern of - AP_Algebraic cons_symbol type_index args _ - # is_cons_expr = IsConstructor expr cons_symbol (length args) {gi_module=cons_symbol.glob_module,gi_index=type_index} case_ident position + AP_Algebraic cons_symbol global_type_index args _ + # is_cons_expr = IsConstructor expr cons_symbol (length args) global_type_index case_ident position e_state & es_fun_defs=ps_fun_defs, es_var_heap = ps_var_heap, es_expr_heap = es_expr_heap -> (is_cons_expr, free_vars, e_state, e_info, cs) # fail_expr = Yes (No,BasicExpr (BVB False)) @@ -923,15 +922,14 @@ checkExpression free_vars expr e_input e_state e_info cs transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (!Optional FreeVar, !Expression)) !Expression !String !Position !*VarHeap !*ExpressionHeap !Dynamics !*CheckState -> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (!Optional FreeVar,!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) -transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs +transform_pattern (AP_Algebraic cons_symbol global_type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs # (var_args, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr pos var_store expr_heap opt_dynamics cs - type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index} pattern_variables = cons_optional opt_var pattern_variables # pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pos} | cons_symbol.glob_module==cPredefinedModuleIndex # pd_cons_index=cons_symbol.glob_object.ds_index+FirstConstructorPredefinedSymbolIndex | pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedNilSymbol - # (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list type_symbol expr_heap cs + # (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list global_type_index expr_heap cs = case pattern_scheme of OverloadedListPatterns (UnboxedList _ _ _ _) _ _ # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns @@ -946,7 +944,7 @@ transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pa -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) | pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_UnboxedTailStrictNilSymbol - # (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list type_symbol expr_heap cs + # (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list global_type_index expr_heap cs = case pattern_scheme of OverloadedListPatterns (UnboxedTailStrictList _ _ _ _) _ _ # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns @@ -963,22 +961,22 @@ transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pa | pd_cons_index==PD_OverloadedConsSymbol || pd_cons_index==PD_OverloadedNilSymbol = case pattern_scheme of OverloadedListPatterns (OverloadedList _ _ _ _) _ _ - # (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list type_symbol expr_heap cs + # (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list global_type_index expr_heap cs # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns -> (OverloadedListPatterns overloaded_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) OverloadedListPatterns (UnboxedList _ _ _ _) _ _ - # (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list type_symbol expr_heap cs + # (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list global_type_index expr_heap cs # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_UnboxedConsSymbol PD_UnboxedNilSymbol cs -> (OverloadedListPatterns unboxed_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) OverloadedListPatterns (UnboxedTailStrictList _ _ _ _) _ _ - # (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list type_symbol expr_heap cs + # (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list global_type_index expr_heap cs # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_UnboxedTailStrictConsSymbol PD_UnboxedTailStrictNilSymbol cs -> (OverloadedListPatterns unboxed_tail_strict_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) AlgebraicPatterns alg_type _ - | alg_type.glob_module==cPredefinedModuleIndex - # index=alg_type.glob_object+FirstTypePredefinedSymbolIndex + | alg_type.gi_module==cPredefinedModuleIndex + # index=alg_type.gi_index+FirstTypePredefinedSymbolIndex | index==PD_ListType # alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns # (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_ConsSymbol PD_NilSymbol cs @@ -998,50 +996,50 @@ transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pa -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) NoPattern - # (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list type_symbol expr_heap cs + # (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list global_type_index expr_heap cs -> (OverloadedListPatterns overloaded_list decons_expr [pattern], OverloadedListPatterns overloaded_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) = case pattern_scheme of AlgebraicPatterns alg_type _ - | type_symbol == alg_type + | global_type_index == alg_type # alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns - -> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error }) OverloadedListPatterns (OverloadedList _ _ _ _) _ _ - | type_symbol.glob_module==cPredefinedModuleIndex - # index=type_symbol.glob_object+FirstTypePredefinedSymbolIndex + | global_type_index.gi_module==cPredefinedModuleIndex + # index=global_type_index.gi_index+FirstTypePredefinedSymbolIndex | index==PD_ListType # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_ConsSymbol PD_NilSymbol cs - -> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern:alg_patterns], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) | index==PD_StrictListType # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_StrictConsSymbol PD_StrictNilSymbol cs - -> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern:alg_patterns], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) | index==PD_TailStrictListType # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_TailStrictConsSymbol PD_TailStrictNilSymbol cs - -> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern:alg_patterns], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) | index==PD_StrictTailStrictListType # alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns # (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_StrictTailStrictConsSymbol PD_StrictTailStrictNilSymbol cs - -> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern:alg_patterns], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) NoPattern - -> (AlgebraicPatterns type_symbol [pattern], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) = case pattern_scheme of AlgebraicPatterns alg_type _ - | type_symbol == alg_type + | global_type_index == alg_type # alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns - -> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) # cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) NoPattern - -> (AlgebraicPatterns type_symbol [pattern], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) + -> (AlgebraicPatterns global_type_index [pattern], AlgebraicPatterns global_type_index [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs) where @@ -1075,7 +1073,6 @@ transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pa # glob_object = {glob_object & ds_index=pds_def,ds_ident=pds_ident} = ({pattern & ap_symbol.glob_object=glob_object},cs) = abort "replace_overloaded_symbol_in_pattern" - transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs # pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = pos} pattern_variables = cons_optional opt_var pattern_variables @@ -1138,7 +1135,7 @@ where insert_as_default expr _ = expr // checkWarning "pattern won't match" transform_pattern (AP_NewType cons_symbol type_index arg opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs # (var_arg, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern arg result_expr pos var_store expr_heap opt_dynamics cs - type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} + type_symbol = {gi_module = cons_symbol.glob_module, gi_index = type_index} pattern_variables = cons_optional opt_var pattern_variables # pattern = { ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pos} = case pattern_scheme of @@ -1643,7 +1640,8 @@ checkPattern (PE_Tuple tuple_args) opt_var p_input accus ps e_info cs # (patterns, arity, accus, ps, e_info, cs) = check_tuple_patterns tuple_args p_input accus ps e_info cs (tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs # ({cons_type_index}, e_info) = e_info!ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index] - = (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, accus, ps, e_info, cs) + # global_type_index = {gi_module = cPredefinedModuleIndex, gi_index = cons_type_index} + = (AP_Algebraic tuple_symbol global_type_index patterns opt_var, accus, ps, e_info, cs) where check_tuple_patterns [] p_input accus ps e_info cs = ([], 0, accus, ps, e_info, cs) @@ -1658,7 +1656,8 @@ checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, Yes (record_symbol, type_index, new_fields) # (patterns, (var_env, array_patterns, ps, e_info, cs)) = mapSt (check_field_pattern p_input) new_fields (var_env, array_patterns, ps, e_info, cs) (patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap - -> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), {ps & ps_var_heap = ps_var_heap}, e_info, cs) + global_type_index = {gi_module = record_symbol.glob_module, gi_index = type_index} + -> (AP_Algebraic record_symbol global_type_index patterns opt_var, (var_env, array_patterns), {ps & ps_var_heap = ps_var_heap}, e_info, cs) No -> (AP_Empty, accus, ps, e_info, cs) where @@ -1802,16 +1801,33 @@ checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_ident = determine_pattern_symbol mod_index ste_index ste_kind cons_ident.id_name ef_cons_defs ef_modules cs_error e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } cons_symbol = { glob_object = MakeDefinedSymbol cons_ident cons_index cons_arity, glob_module = cons_module } - | cons_number <> -2 + | cons_number > -2 + # global_type_index = {gi_module = cons_module, gi_index = cons_type_index} | is_expr_list - = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) - | cons_arity == 0 - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_ident "constructor arguments are missing" cs_error }) + = (AP_Constant (APK_Constructor global_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) + | cons_arity == 0 + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, {cs & cs_error = cs_error}) + # cs & cs_error = checkError cons_ident "constructor arguments are missing" cs_error + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, cs) + | cons_number == -2 | is_expr_list = (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) # cs & cs_error = checkError cons_ident "constructor argument is missing" cs_error = (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs) + // cons_number == -3 + # (type_rhs,e_info) + = case ste_kind of + STE_Constructor + -> e_info!ef_type_defs.[cons_type_index].td_rhs + _ + -> e_info!ef_modules.[cons_module].dcl_common.com_type_defs.[cons_type_index].td_rhs + # (AlgConses _ global_type_index) = type_rhs + | is_expr_list + = (AP_Constant (APK_Constructor global_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) + | cons_arity == 0 + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, {cs & cs_error = cs_error}) + # cs & cs_error = checkError cons_ident "constructor arguments are missing" cs_error + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, cs) where determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error # ({cons_type={st_arity},cons_priority,cons_type_index,cons_number}, cons_defs) = cons_defs![id_index] @@ -1843,16 +1859,33 @@ checkQualifiedPatternConstructor ste_kind ste_index decl_ident module_name ident = determine_pattern_symbol mod_index ste_index ste_kind module_name ident_name ef_cons_defs ef_modules cs_error e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } cons_symbol = { glob_object = MakeDefinedSymbol decl_ident cons_index cons_arity, glob_module = cons_module } - | cons_number <> -2 + | cons_number > -2 + # global_type_index = {gi_module = cons_module, gi_index = cons_type_index} | is_expr_list - = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) - | cons_arity == 0 - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) - = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error }) + = (AP_Constant (APK_Constructor global_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) + | cons_arity == 0 + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, {cs & cs_error = cs_error}) + # cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, cs) + | cons_number == -2 | is_expr_list = (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) # cs & cs_error = checkError ident_name "constructor argument is missing" cs_error = (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs) + // cons_number == -3 + # (type_rhs,e_info) + = case ste_kind of + STE_Constructor + -> e_info!ef_type_defs.[cons_type_index].td_rhs + _ + -> e_info!ef_modules.[cons_module].dcl_common.com_type_defs.[cons_type_index].td_rhs + # (AlgConses _ global_type_index) = type_rhs + | is_expr_list + = (AP_Constant (APK_Constructor global_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error}) + | cons_arity == 0 + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, {cs & cs_error = cs_error}) + # cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error + = (AP_Algebraic cons_symbol global_type_index [] opt_var, ps, e_info, cs) where determine_pattern_symbol mod_index id_index STE_Constructor module_name ident_name cons_defs modules error # ({cons_type={st_arity},cons_priority,cons_type_index,cons_number}, cons_defs) = cons_defs![id_index] @@ -1933,16 +1966,15 @@ convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_e convertSubPattern (AP_Variable name var_info No) result_expr pattern_position var_store expr_heap opt_dynamics cs = ({ fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr pattern_position +convertSubPattern (AP_Algebraic cons_symbol global_type_index args opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr pattern_position var_store expr_heap opt_dynamics cs - type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index } ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position }] - # (case_guards,expr_heap,cs) = make_case_guards cons_symbol type_symbol alg_patterns expr_heap cs + # (case_guards,expr_heap,cs) = make_case_guards cons_symbol global_type_index alg_patterns expr_heap cs = ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, Case { case_expr = Var { var_ident = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr, @@ -1965,7 +1997,7 @@ convertSubPattern (AP_NewType cons_symbol type_index arg opt_var) result_expr pa var_store expr_heap opt_dynamics cs # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern arg result_expr pattern_position var_store expr_heap opt_dynamics cs - type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index } + type_symbol = { gi_module = cons_symbol.glob_module, gi_index = type_index } ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap @@ -2022,7 +2054,7 @@ transfromPatternIntoBind mod_index def_level (AP_Variable name var_info (Yes {bi transfromPatternIntoBind mod_index def_level (AP_Variable name var_info No) src_expr position var_store expr_heap e_info cs # bind = {lb_src = src_expr, lb_dst = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = def_level, fv_count = 0 }, lb_position = position } = ([bind], var_store, expr_heap, e_info, cs) -transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} type_index args opt_var) +transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} global_type_index args opt_var) src_expr position var_store expr_heap e_info=:{ef_type_defs,ef_modules} cs # (src_expr, opt_var_bind, var_store, expr_heap) = bind_opt_var opt_var src_expr position var_store expr_heap | ds_arity == 0 @@ -2031,7 +2063,7 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo | is_tuple # (tuple_var, tuple_bind, var_store, expr_heap) = bind_match_expr src_expr opt_var_bind position def_level var_store expr_heap = transform_sub_patterns mod_index def_level args ds_cons 0 tuple_var tuple_bind position var_store expr_heap e_info cs - # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index glob_module type_index ef_type_defs ef_modules + # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index global_type_index ef_type_defs ef_modules e_info = { e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules } = case td_rhs of RecordType {rt_fields} @@ -2069,7 +2101,7 @@ transfromPatternIntoStrictBind :: !Index !Level !AuxiliaryPattern !Expression !P transfromPatternIntoStrictBind mod_index def_level (AP_Variable name var_info _) src_expr position var_store expr_heap e_info cs # bind = {lb_src = src_expr, lb_dst = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = def_level, fv_count = 0 }, lb_position = position } = ([],[bind], var_store, expr_heap, e_info, cs) -transfromPatternIntoStrictBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} type_index args opt_var) +transfromPatternIntoStrictBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} global_type_index args opt_var) src_expr position var_store expr_heap e_info=:{ef_type_defs,ef_modules} cs # (src_expr, src_bind, var_store, expr_heap) = bind_opt_var_or_create_new_var opt_var src_expr position def_level var_store expr_heap | ds_arity == 0 @@ -2078,7 +2110,7 @@ transfromPatternIntoStrictBind mod_index def_level (AP_Algebraic cons_symbol=:{g | is_tuple # (lazy_binds,var_store,expr_heap,e_info,cs) = transform_sub_patterns mod_index def_level args ds_cons 0 src_expr [] position var_store expr_heap e_info cs = (lazy_binds,src_bind,var_store,expr_heap,e_info,cs) - # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index glob_module type_index ef_type_defs ef_modules + # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index global_type_index ef_type_defs ef_modules e_info = { e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules } = case td_rhs of RecordType {rt_fields} @@ -2108,12 +2140,12 @@ transfromPatternIntoStrictBind mod_index def_level (AP_WildCard _) src_expr _ va transfromPatternIntoStrictBind _ _ pattern src_expr _ var_store expr_heap e_info cs = ([],[],var_store, expr_heap, e_info, { cs & cs_error = checkError "<pattern>" "illegal node pattern" cs.cs_error}) -get_type_def mod_index type_mod_index type_index ef_type_defs ef_modules - | mod_index == type_mod_index - # (type_def, ef_type_defs) = ef_type_defs![type_index] +get_type_def mod_index global_type_index=:{gi_module,gi_index} ef_type_defs ef_modules + | mod_index == gi_module + # (type_def, ef_type_defs) = ef_type_defs![gi_index] = (type_def, ef_type_defs, ef_modules) - # ({dcl_common}, ef_modules) = ef_modules![type_mod_index] - = (dcl_common.com_type_defs.[type_index], ef_type_defs, ef_modules) + # ({dcl_common}, ef_modules) = ef_modules![gi_module] + = (dcl_common.com_type_defs.[gi_index], ef_type_defs, ef_modules) is_tuple_symbol cons_module cons_index cs # (tuple_2_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex 2) PD_PredefinedModule STE_Constructor 2 cs @@ -2237,7 +2269,8 @@ where | cons_def.cons_type.st_arity == length app_args+length extra_args # (patterns, ums) = mapSt (unfold_pattern_macro mod_index macro_ident No []) app_args { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules } cons_symbol = { glob_object = MakeDefinedSymbol symb_ident cons_index cons_def.cons_type.st_arity, glob_module = glob_module } - = (AP_Algebraic cons_symbol cons_def.cons_type_index (patterns++extra_args) opt_var, ums) + global_type_index = {gi_module = glob_module, gi_index = cons_def.cons_type_index} + = (AP_Algebraic cons_symbol global_type_index (patterns++extra_args) opt_var, ums) = (AP_Empty, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, ums_error = checkError cons_def.cons_ident "incorrect number of arguments" ums_error }) where diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 1a290a8..4a439d7 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -21,6 +21,7 @@ where toInt STE_DclFunction = cFunctionDefs toInt (STE_FunctionOrMacro _) = cMacroDefs toInt (STE_DclMacroOrLocalMacroFunction _)= cMacroDefs + toInt STE_TypeExtension = cTypeDefs toInt _ = NoIndex instance Erroradmin ErrorAdmin diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index e4e46f0..6bb24d9 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -133,7 +133,7 @@ retrieveTypeDefinition type_ptr mod_index symbol_table used_types with retrieve_type_definition (STE_UsedQualifiedType uqt_mod_index uqt_index orig_kind) | uqt_mod_index==mod_index && uqt_index==ste_index - = (ste_index, mod_index, symbol_table, used_types) + = (ste_index, mod_index, symbol_table, used_types) = retrieve_type_definition orig_kind retrieve_type_definition (STE_Imported STE_Type ste_mod_index) = (ste_index, ste_mod_index, symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType ste_mod_index this_kind }), used_types) @@ -376,9 +376,9 @@ where # type_lhs = { at_attribute = cti_lhs_attribute, at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity) [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} - ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs + ts_ti_cs = bind_types_of_constructors cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs conses ts_ti_cs = (td_rhs, ts_ti_cs) - check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index,ds_arity}, rt_fields}} + check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor={ds_index,ds_arity}, rt_fields}} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} (ts,ti,cs) # type_lhs = { at_attribute = cti_lhs_attribute, at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity) @@ -386,7 +386,7 @@ where cs = if (ds_arity>32) { cs & cs_error = checkError ("Record has too many fields ("+++toString ds_arity+++",") "32 are allowed)" cs.cs_error } cs; - (ts, ti, cs) = bind_types_of_constructor cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs rec_cons (ts,ti,cs) + (ts, ti, cs) = bind_types_of_constructor cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs ds_index (ts,ti,cs) # (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index] # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def # (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars @@ -429,33 +429,69 @@ where # type_lhs = { at_attribute = cti_lhs_attribute, at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity) [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} - ts_ti_cs = bind_types_of_constructor cti -2 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs cons ts_ti_cs + ts_ti_cs = bind_types_of_constructor cti -2 (atype_vars_to_type_vars td_args) attr_vars type_lhs cons.ds_index ts_ti_cs = (td_rhs, ts_ti_cs) check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti ts_ti_cs # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs = (AbstractSynType properties type, ts_ti_cs) + check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:ExtendableAlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} class_defs_ts_ti_cs + # type_lhs = { at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent {glob_object = cti_type_index, glob_module = cti_module_index} td_ident td_arity) + [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + class_defs_ts_ti_cs = bind_types_of_constructors cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs conses class_defs_ts_ti_cs + = (td_rhs, class_defs_ts_ti_cs) + check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:UncheckedAlgConses type_ext_ident conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # (ts,ti,cs) = ts_ti_cs + (type_index, type_module, cs_symbol_table, ti_used_types) = retrieveTypeDefinition td_ident.id_info cti_module_index cs.cs_symbol_table ti.ti_used_types + ti & ti_used_types = ti_used_types + cs & cs_symbol_table = cs_symbol_table + | type_index <> NotFound + # ts_ti_cs = (ts,ti,cs) + // to do check if ExtendableAlgType + # type_lhs = { at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = type_index, glob_module = type_module } td_ident td_arity) + [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + ts_ti_cs = bind_types_of_added_constructors cti (atype_vars_to_type_vars td_args) attr_vars type_lhs conses ts_ti_cs + = (AlgConses conses {gi_module=type_module,gi_index=type_index}, ts_ti_cs) + # cs & cs_error = checkError td_ident "undefined" cs.cs_error + = (td_rhs, (ts,ti,cs)) check_rhs_of_TypeDef {td_rhs} _ _ ts_ti_cs = (td_rhs, ts_ti_cs) + atype_vars_to_type_vars atype_vars + = [atv_variable \\ {atv_variable} <- atype_vars] + bind_types_of_constructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState) -> (!*TypeSymbols, !*TypeInfo, !*CheckState) bind_types_of_constructors cti cons_index free_vars free_attrs type_lhs [cons=:{ds_arity,ds_ident,ds_index}:conses] (ts,ti,cs) # (ts,cs) = if (ds_arity>32) (constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs) (ts,cs); - # ts_ti_cs = bind_types_of_constructor cti cons_index free_vars free_attrs type_lhs cons (ts,ti,cs) + # ts_ti_cs = bind_types_of_constructor cti cons_index free_vars free_attrs type_lhs ds_index (ts,ti,cs) = bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses ts_ti_cs bind_types_of_constructors _ _ _ _ _ [] ts_ti_cs = ts_ti_cs + bind_types_of_added_constructors :: !CurrentTypeInfo ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] + !(!*TypeSymbols,!*TypeInfo,!*CheckState) + -> (!*TypeSymbols,!*TypeInfo,!*CheckState) + bind_types_of_added_constructors cti free_vars free_attrs type_lhs [{ds_arity,ds_ident,ds_index}:conses] (ts,ti,cs) + # (ts,cs) = if (ds_arity>32) + (constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs) + (ts,cs); + # class_defs_ts_ti_cs = bind_types_of_constructor cti -3 free_vars free_attrs type_lhs ds_index (ts,ti,cs) + = bind_types_of_added_constructors cti free_vars free_attrs type_lhs conses class_defs_ts_ti_cs + bind_types_of_added_constructors _ _ _ _ [] class_defs_ts_ti_cs + = class_defs_ts_ti_cs + constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs # (cons_pos,ts2) = ts!ts_cons_defs.[ds_index].cons_pos = (ts2, {cs & cs_error = checkErrorWithPosition ds_ident cons_pos ("Constructor has too many arguments ("+++toString ds_arity+++", 32 are allowed)") cs.cs_error}) - bind_types_of_constructor :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType !DefinedSymbol !(!*TypeSymbols,!*TypeInfo,!*CheckState) + bind_types_of_constructor :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType !Index !(!*TypeSymbols,!*TypeInfo,!*CheckState) -> (!*TypeSymbols, !*TypeInfo, !*CheckState) - bind_types_of_constructor cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs {ds_index} (ts, ti=:{ti_type_heaps}, cs) - # (cons_def, ts) = ts!ts_cons_defs.[ds_index] + bind_types_of_constructor cti=:{cti_lhs_attribute} cons_number free_vars free_attrs type_lhs cons_index (ts, ti=:{ti_type_heaps}, cs) + # (cons_def, ts) = ts!ts_cons_defs.[cons_index] # (exi_vars, (ti_type_heaps, cs)) = addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs (st_args, st_attr_env, (ts, ti, cs)) @@ -464,9 +500,9 @@ where attr_vars = add_universal_attr_vars st_args free_attrs cons_type = {cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = attr_vars, st_attr_env = st_attr_env} (new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap - cons_def = { cons_def & cons_type = cons_type, cons_number = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, + cons_def = { cons_def & cons_type = cons_type, cons_number = cons_number, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, cons_type_ptr = new_type_ptr } - = ({ts & ts_cons_defs.[ds_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table}) + = ({ts & ts_cons_defs.[cons_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table}) where bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState) -> (![AType], ![AttrInequality],!(!*TypeSymbols, !*TypeInfo, !*CheckState)) diff --git a/frontend/classify.icl b/frontend/classify.icl index 86e8f68..5279695 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -685,11 +685,13 @@ instance consumerRequirements Case where _ -> False inspect_patterns :: !{#CommonDefs} !Bool !CasePatterns ![(Int,Bool)] -> (!Bool,!Bool) - inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object,glob_module} _) constructors_and_unsafe_bits - # type_def = common_defs.[glob_module].com_type_defs.[glob_object] + inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} algebraic_patterns) constructors_and_unsafe_bits + # type_def = common_defs.[gi_module].com_type_defs.[gi_index] defined_symbols = case type_def.td_rhs of AlgType defined_symbols -> defined_symbols RecordType {rt_constructor} -> [rt_constructor] + ExtendableAlgType defined_symbols -> defined_symbols + AlgConses defined_symbols _ -> defined_symbols all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ] all_sorted_constructors = if (is_sorted all_constructors) all_constructors @@ -699,15 +701,17 @@ instance consumerRequirements Case where = (appearance_loop [0,1] constructors_and_unsafe_bits, not (multimatch_loop has_default constructors_and_unsafe_bits)) inspect_patterns common_defs has_default (OverloadedListPatterns overloaded_list _ _) constructors_and_unsafe_bits # type_def = case overloaded_list of - UnboxedList {glob_module,glob_object} _ _ _ - -> common_defs.[glob_module].com_type_defs.[glob_object] - UnboxedTailStrictList {glob_object,glob_module} _ _ _ - -> common_defs.[glob_module].com_type_defs.[glob_object] - OverloadedList {glob_object,glob_module} _ _ _ - -> common_defs.[glob_module].com_type_defs.[glob_object] + UnboxedList {gi_index,gi_module} _ _ _ + -> common_defs.[gi_module].com_type_defs.[gi_index] + UnboxedTailStrictList {gi_index,gi_module} _ _ _ + -> common_defs.[gi_module].com_type_defs.[gi_index] + OverloadedList {gi_index,gi_module} _ _ _ + -> common_defs.[gi_module].com_type_defs.[gi_index] defined_symbols = case type_def.td_rhs of AlgType defined_symbols -> defined_symbols RecordType {rt_constructor} -> [rt_constructor] + ExtendableAlgType defined_symbols -> defined_symbols + AlgConses defined_symbols _ -> defined_symbols all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ] all_sorted_constructors = if (is_sorted all_constructors) all_constructors (sortBy (<) all_constructors) = (appearance_loop all_sorted_constructors constructors_and_unsafe_bits, not (multimatch_loop has_default constructors_and_unsafe_bits)) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 3b82ebb..c408bc8 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -72,6 +72,14 @@ where compare_rhs_of_types (AbstractSynType _ dclType) (SynType iclType) dcl_cons_defs icl_cons_defs comp_st # (ok, comp_st) = compare dclType iclType comp_st = (ok, icl_cons_defs, comp_st) + compare_rhs_of_types (ExtendableAlgType []) (ExtendableAlgType []) dcl_cons_defs icl_cons_defs comp_st + = (True, icl_cons_defs, comp_st) + compare_rhs_of_types (ExtendableAlgType dclConstructors) (ExtendableAlgType iclConstructors) dcl_cons_defs icl_cons_defs comp_st + = compare_constructor_lists dclConstructors iclConstructors dcl_cons_defs icl_cons_defs comp_st + compare_rhs_of_types (AlgConses dclConstructors dcl_type_index) (AlgConses iclConstructors icl_type_index) dcl_cons_defs icl_cons_defs comp_st + | dcl_type_index==icl_type_index + = compare_constructor_lists dclConstructors iclConstructors dcl_cons_defs icl_cons_defs comp_st + = (False, icl_cons_defs, comp_st) compare_rhs_of_types dcl_type icl_type dcl_cons_defs icl_cons_defs comp_st = (False, icl_cons_defs, comp_st) @@ -85,7 +93,7 @@ where = compare_constructor_lists dcl_conses icl_conses dcl_cons_defs icl_cons_defs comp_st = (False, icl_cons_defs, comp_st) = (False, icl_cons_defs, comp_st) - compare_constructor_lists [dcl_cons : dcl_conses] [] dcl_cons_defs icl_cons_defs comp_st + compare_constructor_lists _ _ dcl_cons_defs icl_cons_defs comp_st = (False, icl_cons_defs, comp_st) compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st @@ -962,6 +970,8 @@ instance t_corresponds TypeRhs where = t_corresponds dclType iclType t_corresponds (NewType dclConstructor) (NewType iclConstructor) = t_corresponds dclConstructor iclConstructor + t_corresponds (ExtendableAlgType dclConstructors) (ExtendableAlgType iclConstructors) + = t_corresponds dclConstructors iclConstructors // sanity check ... t_corresponds UnknownType _ diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 801e1ac..2780825 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -20,7 +20,7 @@ import type_io; :: DynamicRepresentation = !{ dr_type_ident :: SymbIdent - , dr_dynamic_type :: Global Index + , dr_dynamic_type :: GlobalIndex , dr_dynamic_symbol :: Global DefinedSymbol , dr_type_code_constructor_symb_ident :: SymbIdent } @@ -740,7 +740,7 @@ create_dynamic_and_selector_idents common_defs predefined_symbols # dynamic_defined_symbol = {glob_module = pds_module1, glob_object = rt_constructor} - # dynamic_type = {glob_module = pds_module1, glob_object = pds_def1} + # dynamic_type = {gi_module = pds_module1, gi_index = pds_def1} # dynamic_temp_symb_ident = { SymbIdent | diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index aff1e38..cb0120e 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -1590,7 +1590,7 @@ where true_expr = BasicExpr (BVB True) (var_args,cs_var_heap) = make_free_vars cons_arity cs_var_heap pattern = {ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = true_expr, ap_position = position} - patterns = AlgebraicPatterns {glob_module=global_type_index.gi_module,glob_object=global_type_index.gi_index} [pattern] + patterns = AlgebraicPatterns global_type_index [pattern] (case_expr_ptr, cs_expr_heap) = newPtr EI_Empty cs_expr_heap case_expr = Case {case_expr = case_var, case_guards = patterns, case_default = Yes fail_expr, case_ident = No, case_explicit = False, case_info_ptr = case_expr_ptr, case_default_pos = NoPos} diff --git a/frontend/generics1.icl b/frontend/generics1.icl index 9292e0a..0bde0b2 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -401,7 +401,7 @@ where | can_generate_bimap_to_or_from #! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds #! (args, st) = convert_args args (modules, td_infos, heaps, error) - -> (GTSAppConsSimpleType type_index (KindArrow tdi_kinds) args, st) + -> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st) -> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error _ -> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error @@ -976,7 +976,7 @@ where build_expr_for_conses is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error # (case_alts, heaps, error) = build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms heaps error - # case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts + # case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} case_alts # (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps = (case_expr, heaps, error) @@ -1049,7 +1049,7 @@ buildConversionFrom :: FunsAndGroups,!*Heaps,!*ErrorAdmin) buildConversionFrom type_def_mod - type_def=:{td_rhs, td_ident, td_index, td_pos} + type_def=:{td_rhs, td_ident, td_pos} main_module_index predefs funs_and_groups heaps error # (body_expr, arg_var, heaps, error) = build_expr_for_type_rhs type_def_mod td_rhs heaps error @@ -1148,7 +1148,7 @@ where build_case_unit body_expr heaps # unit_pat = buildPredefConsPattern PD_ConsUNIT [] body_expr predefs # {pds_module, pds_def} = predefs.[PD_TypeUNIT] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [unit_pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [unit_pat] = build_case_expr case_patterns heaps build_pair x y predefs heaps @@ -1172,32 +1172,32 @@ build_field var_expr predefs heaps build_case_pair var1 var2 body_expr predefs heaps # pair_pat = buildPredefConsPattern PD_ConsPAIR [var1, var2] body_expr predefs # {pds_module, pds_def} = predefs.[PD_TypePAIR] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pair_pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pair_pat] = build_case_expr case_patterns heaps build_case_either left_var left_expr right_var right_expr predefs heaps # left_pat = buildPredefConsPattern PD_ConsLEFT [left_var] left_expr predefs # right_pat = buildPredefConsPattern PD_ConsRIGHT [right_var] right_expr predefs # {pds_module, pds_def} = predefs.[PD_TypeEITHER] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [left_pat, right_pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [left_pat, right_pat] = build_case_expr case_patterns heaps build_case_object var body_expr predefs heaps # pat = buildPredefConsPattern PD_ConsOBJECT [var] body_expr predefs # {pds_module, pds_def} = predefs.[PD_TypeOBJECT] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat] = build_case_expr case_patterns heaps build_case_cons var body_expr predefs heaps # pat = buildPredefConsPattern PD_ConsCONS [var] body_expr predefs # {pds_module, pds_def} = predefs.[PD_TypeCONS] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat] = build_case_expr case_patterns heaps build_case_field var body_expr predefs heaps # pat = buildPredefConsPattern PD_ConsFIELD [var] body_expr predefs # {pds_module, pds_def} = predefs.[PD_TypeFIELD] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat] + # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat] = build_case_expr case_patterns heaps // case with a variable as the selector expression @@ -2769,13 +2769,13 @@ where build_generic_app kind arg_exprs gen_index gen_ident heaps = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps - bimap_to_simple_type :: !(Global Index) !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) - -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) - bimap_to_simple_type global_type_def_index=:{glob_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) + bimap_to_simple_type :: !GlobalIndex !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) + -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) + bimap_to_simple_type global_type_def_index=:{gi_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) # (alts,constructors_arg_types,modules,heaps) = determine_constructors_arg_types global_type_def_index arg_types modules heaps # (alg_patterns,funs_and_groups,modules,heaps,error) - = build_to_alg_patterns alts constructors_arg_types glob_module funs_and_groups modules heaps error + = build_to_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error = build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error where build_to_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error @@ -2804,13 +2804,13 @@ where specialize_to_with_args [] [] st = ([],st) - bimap_from_simple_type :: !(Global Index) !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) - -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) - bimap_from_simple_type global_type_def_index=:{glob_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) + bimap_from_simple_type :: !GlobalIndex !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) + -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) + bimap_from_simple_type global_type_def_index=:{gi_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) # (alts,constructors_arg_types,modules,heaps) = determine_constructors_arg_types global_type_def_index arg_types modules heaps # (alg_patterns,funs_and_groups,modules,heaps,error) - = build_from_alg_patterns alts constructors_arg_types glob_module funs_and_groups modules heaps error + = build_from_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error = build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error where build_from_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error @@ -2839,16 +2839,16 @@ where specialize_from_with_args [] [] st = ([],st) - determine_constructors_arg_types :: !(Global Index) ![GenTypeStruct] !*Modules !*Heaps - -> (![DefinedSymbol],![[GenTypeStruct]],!*Modules,!*Heaps) - determine_constructors_arg_types {glob_module,glob_object} arg_types modules heaps - # ({td_args,td_rhs=AlgType alts},modules) = modules![glob_module].com_type_defs.[glob_object] + determine_constructors_arg_types :: !GlobalIndex ![GenTypeStruct] !*Modules !*Heaps + -> (![DefinedSymbol],![[GenTypeStruct]],!*Modules,!*Heaps) + determine_constructors_arg_types {gi_module,gi_index} arg_types modules heaps + # ({td_args,td_rhs=AlgType alts},modules) = modules![gi_module].com_type_defs.[gi_index] # {hp_type_heaps} = heaps # th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars # arg_types_a = {!arg_type\\arg_type<-arg_types} # (constructors_arg_types,modules,th_vars) - = compute_constructors_arg_types alts glob_module arg_types_a modules th_vars + = compute_constructors_arg_types alts gi_module arg_types_a modules th_vars # th_vars = remove_type_argument_numbers td_args th_vars # heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}} = (alts,constructors_arg_types,modules,heaps) @@ -2876,8 +2876,8 @@ where compute_constructor_arg_types [] arg_types_a th_vars = ([],th_vars) - build_bimap_case :: !(Global Index) !.Expression ![AlgebraicPattern] !FunsAndGroups !*Modules !*Heaps !*ErrorAdmin - -> (!Expression,!(!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)) + build_bimap_case :: !GlobalIndex !.Expression ![AlgebraicPattern] !FunsAndGroups !*Modules !*Heaps !*ErrorAdmin + -> (!Expression,!(!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)) build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error # case_patterns = AlgebraicPatterns global_type_def_index alg_patterns # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap @@ -3834,8 +3834,7 @@ curryGenericArgType st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_va = (curried_st, {th & th_attrs = th_attrs}) //---> ("curryGenericArgType", st, curried_st) -curryGenericArgType1 :: !SymbolType !String !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) +curryGenericArgType1 :: !SymbolType !String !*TypeHeaps -> (!SymbolType, !*TypeHeaps) curryGenericArgType1 st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs} # (atype, attr_vars, av_num, th_attrs) = curry st_args st_result 1 th_attrs # curried_st = {st & st_args = [], st_arity = 0, st_result = atype, st_attr_vars = attr_vars} diff --git a/frontend/hashtable.dcl b/frontend/hashtable.dcl index 088d5ae..326d724 100644 --- a/frontend/hashtable.dcl +++ b/frontend/hashtable.dcl @@ -25,6 +25,7 @@ set_hte_mark :: !Int !*HashTable -> *HashTable | IC_InstanceMember ![Type] | IC_Generic | IC_GenericCase !Type + | IC_TypeExtension !{#Char}/*module name*/ | IC_Unknown :: QualifiedIdents = QualifiedIdents !Ident !IdentClass !QualifiedIdents diff --git a/frontend/hashtable.icl b/frontend/hashtable.icl index eb011b1..b5e8552 100644 --- a/frontend/hashtable.icl +++ b/frontend/hashtable.icl @@ -23,6 +23,7 @@ import predef, syntax, compare_types, compare_constructor | IC_InstanceMember ![Type] | IC_Generic | IC_GenericCase !Type + | IC_TypeExtension !{#Char}/*module name*/ | IC_Unknown :: QualifiedIdents = QualifiedIdents !Ident !IdentClass !QualifiedIdents @@ -46,6 +47,8 @@ where = type1 =< type2 (=<) (IC_Field typ_id1) (IC_Field typ_id2) = typ_id1 =< typ_id2 + (=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2) + = module_name1=<module_name2 (=<) ic1 ic2 | equal_constructor ic1 ic2 = Equal diff --git a/frontend/mergecases.icl b/frontend/mergecases.icl index fee3c4c..40f2579 100644 --- a/frontend/mergecases.icl +++ b/frontend/mergecases.icl @@ -298,8 +298,8 @@ where # (merged_patterns, var_heap, symbol_heap, error) = merge_dynamic_patterns patterns1 patterns2 var_heap symbol_heap error = (DynamicPatterns merged_patterns, var_heap, symbol_heap, error) merge_guards guards=:(AlgebraicPatterns type1 patterns1) (OverloadedListPatterns type2 decons_expr2 patterns2) var_heap symbol_heap error - | type1.glob_module==cPredefinedModuleIndex && isOverloaded type2 - # index=type1.glob_object+FirstTypePredefinedSymbolIndex + | type1.gi_module==cPredefinedModuleIndex && isOverloaded type2 + # index=type1.gi_index+FirstTypePredefinedSymbolIndex | index==PD_ListType # patterns2=replace_overloaded_symbols_in_patterns patterns2 PD_ConsSymbol PD_NilSymbol = merge_algebraic_patterns type1 patterns1 patterns2 var_heap symbol_heap error @@ -314,8 +314,8 @@ where = merge_algebraic_patterns type1 patterns1 patterns2 var_heap symbol_heap error = (guards, var_heap, symbol_heap, incompatible_patterns_in_case_error error) merge_guards guards=:(OverloadedListPatterns type1 decons_expr1 patterns1) (AlgebraicPatterns type2 patterns2) var_heap symbol_heap error - | type2.glob_module==cPredefinedModuleIndex && isOverloaded type1 - # index=type2.glob_object+FirstTypePredefinedSymbolIndex + | type2.gi_module==cPredefinedModuleIndex && isOverloaded type1 + # index=type2.gi_index+FirstTypePredefinedSymbolIndex | index==PD_ListType # patterns1=replace_overloaded_symbols_in_patterns patterns1 PD_ConsSymbol PD_NilSymbol = merge_algebraic_patterns type2 patterns1 patterns2 var_heap symbol_heap error diff --git a/frontend/parse.icl b/frontend/parse.icl index 721a66a..c97e7c3 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1806,8 +1806,8 @@ where -> want_record_type_rhs name True exi_vars pState -> (PD_Type td, parseError "Record type" No ("after ! in definition of record type "+name+" { ") pState) _ - # (condefs, pState) = want_constructor_list exi_vars token pState - # td = {td & td_rhs = ConsList condefs} + # (condefs, extendable_algebraic_type, pState) = want_constructor_list exi_vars token pState + # td & td_rhs = if extendable_algebraic_type (ExtendableConses condefs) (ConsList condefs) | annot == AN_None -> (PD_Type td, pState) -> (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState) @@ -1851,6 +1851,20 @@ where = (PD_Type td, pState) = (PD_Type td, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState)) + want_type_rhs BarToken parseContext td=:{td_ident,td_attribute} annot pState + # name = td_ident.id_name + pState = verify_annot_attr annot td_attribute name pState + (exi_vars, pState) = optionalExistentialQuantifiedVariables pState + (token, pState) = nextToken GeneralContext pState // should be TypeContext + (condefs, pState) = want_more_constructors exi_vars token pState + (file_name, pState) = getFilename pState + module_name = file_name % (0,size file_name-4) + (type_ext_ident, pState) = stringToIdent name (IC_TypeExtension module_name) pState + td & td_rhs = MoreConses type_ext_ident condefs + | annot == AN_None + = (PD_Type td, pState) + = (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState) + want_type_rhs token parseContext td=:{td_attribute} annot pState | isIclContext parseContext = (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState) @@ -1879,14 +1893,27 @@ where = (TA_None, cAllBitsClear) = (attr, cIsNonCoercible) - want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState) + want_constructor_list :: ![ATypeVar] !Token !ParseState -> (![ParsedConstructor],!Bool,!ParseState) + want_constructor_list exi_vars DotDotToken pState + = ([], True, pState) want_constructor_list exi_vars token pState # (cons,pState) = want_constructor exi_vars token pState (token, pState) = nextToken TypeContext pState | token == BarToken # (exi_vars, pState) = optionalExistentialQuantifiedVariables pState (token, pState) = nextToken GeneralContext pState - (cons_list, pState) = want_constructor_list exi_vars token pState + (cons_list, extendable_algebraic_type, pState) = want_constructor_list exi_vars token pState + = ([cons : cons_list], extendable_algebraic_type, pState) + = ([cons], False, tokenBack pState) + + want_more_constructors :: ![ATypeVar] !Token !ParseState -> (![ParsedConstructor],!ParseState) + want_more_constructors exi_vars token pState + # (cons,pState) = want_constructor exi_vars token pState + (token, pState) = nextToken TypeContext pState + | token == BarToken + # (exi_vars, pState) = optionalExistentialQuantifiedVariables pState + (token, pState) = nextToken GeneralContext pState + (cons_list, pState) = want_more_constructors exi_vars token pState = ([cons : cons_list], pState) = ([cons], tokenBack pState) diff --git a/frontend/postparse.icl b/frontend/postparse.icl index c384ca8..c34395f 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1318,6 +1318,20 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = AbstractTypeSpec p type_def = { type_def & td_rhs = AbstractSynType properties type } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = ExtendableConses cons_defs} : defs] def_counts=:{cons_count,type_count} ca + # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count + def_counts & cons_count=cons_count, type_count=type_count+1 + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca + type_def & td_rhs = ExtendableAlgType cons_symbs + c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = MoreConses type_ext_ident cons_defs} : defs] def_counts=:{cons_count,type_count} ca + # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count + def_counts & cons_count=cons_count, type_count=type_count+1 + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca + type_def & td_rhs = UncheckedAlgConses type_ext_ident cons_symbs + c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Class class_def=:{class_ident,class_arity,class_args} members : defs] def_counts=:{mem_count} ca # type_context = { tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = class_ident, ds_arity = class_arity, ds_index = NoIndex }}, tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr} diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 37d020a..ab17380 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -74,6 +74,7 @@ instance == FunctionOrMacroIndex | STE_UsedQualifiedType !ModuleN !Index !STE_Kind | STE_BelongingSymbolExported | STE_BelongingSymbolForExportedSymbol + | STE_TypeExtension :: ModuleN:==Int; @@ -185,6 +186,8 @@ instance == FunctionOrMacroIndex | NewTypeCons !ParsedConstructor | EmptyRhs !BITVECT | AbstractTypeSpec !BITVECT !AType + | ExtendableConses ![ParsedConstructor] + | MoreConses !Ident ![ParsedConstructor] :: CollectedDefinitions instance_kind = { def_types :: ![TypeDef TypeRhs] @@ -523,6 +526,9 @@ cIsImportedObject :== False | NewType !DefinedSymbol | AbstractType !BITVECT | AbstractSynType !BITVECT !AType + | ExtendableAlgType ![DefinedSymbol] + | AlgConses ![DefinedSymbol] !GlobalIndex + | UncheckedAlgConses !Ident ![DefinedSymbol] | UnknownType :: ParsedTypeDef :== TypeDef RhsDefsOfType @@ -578,7 +584,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex} | GTSE | GTSAppConsBimapKindConst // for optimizing bimaps | GTSAppBimap TypeKind [GenTypeStruct] // for optimizing bimaps - | GTSAppConsSimpleType !(Global Index) !TypeKind ![GenTypeStruct] // for optimizing bimaps + | GTSAppConsSimpleType !GlobalIndex !TypeKind ![GenTypeStruct] // for optimizing bimaps :: GenericTypeRep = { gtr_type :: GenTypeStruct // generic structure type @@ -699,7 +705,7 @@ pIsSafe :== True :: OptionalVariable :== Optional (Bind Ident VarInfoPtr) :: AuxiliaryPattern - = AP_Algebraic !(Global DefinedSymbol) !Index [AuxiliaryPattern] OptionalVariable + = AP_Algebraic !(Global DefinedSymbol) !GlobalIndex ![AuxiliaryPattern] !OptionalVariable | AP_Variable !Ident !VarInfoPtr OptionalVariable | AP_Basic !BasicValue OptionalVariable | AP_NewType !(Global DefinedSymbol) !Index AuxiliaryPattern OptionalVariable @@ -708,7 +714,7 @@ pIsSafe :== True | AP_WildCard !OptionalVariable | AP_Empty -:: AP_Kind = APK_Constructor !Index | APK_NewTypeConstructor !Index | APK_Macro !Bool // is_dcl_macro +:: AP_Kind = APK_Constructor !GlobalIndex | APK_NewTypeConstructor !Index | APK_Macro !Bool // is_dcl_macro :: VI_TypeInfo = VITI_Empty | VITI_Coercion CoercionPosition @@ -930,7 +936,7 @@ cNotVarNumber :== -1 { cons_ident :: !Ident , cons_type :: !SymbolType , cons_priority :: !Priority - , cons_number :: !Index // -2 for newtype constructor + , cons_number :: !Index // -2 for newtype constructor, -3 for added constructor , cons_type_index :: !Index , cons_exi_vars :: ![ATypeVar] , cons_type_ptr :: !VarInfoPtr @@ -1362,16 +1368,16 @@ cIsNotStrict :== False , dyn_type_code :: !TypeCodeExpression /* filled after type checking */ } -:: CasePatterns= AlgebraicPatterns !(Global Index) ![AlgebraicPattern] +:: CasePatterns= AlgebraicPatterns !GlobalIndex ![AlgebraicPattern] | BasicPatterns !BasicType [BasicPattern] - | NewTypePatterns !(Global Index) ![AlgebraicPattern] + | NewTypePatterns !GlobalIndex ![AlgebraicPattern] | DynamicPatterns [DynamicPattern] /* auxiliary */ | OverloadedListPatterns !OverloadedListType !Expression ![AlgebraicPattern] | NoPattern /* auxiliary */ -:: OverloadedListType = UnboxedList !(Global Index) !Index !Index !Index // list_type_symbol StdStrictLists module index, decons_u index, nil_u index - | UnboxedTailStrictList !(Global Index) !Index !Index !Index // list_type_symbol StdStrictLists module index, decons_uts index, nil_uts index - | OverloadedList !(Global Index) !Index !Index !Index // list_type_symbol StdStrictLists module index, decons index, nil index +:: OverloadedListType = UnboxedList !GlobalIndex !Index !Index !Index // list_type_symbol StdStrictLists module index, decons_u index, nil_u index + | UnboxedTailStrictList !GlobalIndex !Index !Index !Index // list_type_symbol StdStrictLists module index, decons_uts index, nil_uts index + | OverloadedList !GlobalIndex !Index !Index !Index // list_type_symbol StdStrictLists module index, decons index, nil index instance == OverloadedListType diff --git a/frontend/type.icl b/frontend/type.icl index eab10c7..596d063 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -760,40 +760,98 @@ fresh_environment inequalities attr_env attr_heap is_new_ineqality dem_attr_var off_attr_var [] = True -freshAlgebraicType :: !(Global Int) ![AlgebraicPattern] !{#CommonDefs} !*TypeState -> (![[AType]],!AType,![AttrCoercion],!TypeRhs,!*TypeState) -freshAlgebraicType {glob_module,glob_object} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_exis_variables} - # {td_rhs,td_args,td_attrs,td_ident,td_attribute} = common_defs.[glob_module].com_type_defs.[glob_object] +freshAlgebraicType :: !GlobalIndex ![AlgebraicPattern] !{#CommonDefs} !*TypeState -> (![[AType]],!AType,![AttrCoercion],!TypeRhs,!*TypeState) +freshAlgebraicType {gi_module,gi_index} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_exis_variables} + # {td_rhs,td_args,td_attrs} = common_defs.[gi_module].com_type_defs.[gi_index] # (th_vars, ts_var_store) = fresh_type_variables td_args (ts_type_heaps.th_vars, ts_var_store) (th_attrs, ts_attr_store) = fresh_attributes td_attrs (ts_type_heaps.th_attrs, ts_attr_store) ts_type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } - (cons_types, alg_type, attr_env, ts_var_store, ts_attr_store, ts_type_heaps, ts_exis_variables) - = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store ts_attr_store ts_type_heaps ts_exis_variables + (cons_types, alg_type, attr_env, constructor_contexts, ts_var_store, ts_attr_store, ts_type_heaps, ts_exis_variables) + = fresh_symbol_types patterns common_defs td_attrs td_args ts_var_store ts_attr_store ts_type_heaps ts_exis_variables = (cons_types, alg_type, attr_env, td_rhs, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = ts_type_heaps, ts_exis_variables = ts_exis_variables }) where - fresh_symbol_types [{ap_symbol={glob_object},ap_expr}] cons_defs var_store attr_store type_heaps all_exis_variables - # {cons_type = ct=:{st_args,st_attr_env,st_result}, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps - (attr_env, th_attrs) = fresh_environment st_attr_env [] type_heaps.th_attrs - (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs } - (fresh_args, type_heaps) = freshCopy st_args type_heaps - all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables - = ([fresh_args], result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) - fresh_symbol_types [{ap_symbol={glob_object},ap_expr} : patterns] cons_defs var_store attr_store type_heaps all_exis_variables - # (cons_types, result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) - = fresh_symbol_types patterns cons_defs var_store attr_store type_heaps all_exis_variables - {cons_type = ct=:{st_args,st_attr_env}, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps - (attr_env, th_attrs) = fresh_environment st_attr_env attr_env type_heaps.th_attrs - (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs } - all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables - = ([fresh_args : cons_types], result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) + fresh_symbol_types [{ap_symbol={glob_object,glob_module},ap_expr}] common_defs td_attrs td_args var_store attr_store type_heaps all_exis_variables + # {cons_type = {st_args,st_attr_env,st_result,st_context}, cons_exi_vars, cons_number, cons_type_index} = common_defs.[glob_module].com_cons_defs.[glob_object.ds_index] + | cons_number <> -3 + # (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env [] type_heaps.th_attrs + (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs } + (fresh_args, type_heaps) = freshCopy st_args type_heaps + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + | isEmpty st_context + = ([fresh_args], result_type, attr_env, [], var_store, attr_store, type_heaps, all_exis_variables) + # (context, type_heaps) = freshTypeContexts_no_fresh_context_vars st_context type_heaps // fresh_context_vars are created later + = ([fresh_args], result_type, attr_env, [(glob_object,context)], var_store, attr_store, type_heaps, all_exis_variables) + # extension_type = common_defs.[glob_module].com_type_defs.[cons_type_index] + th_vars = copy_type_variables extension_type.td_args td_args type_heaps.th_vars + th_attrs = copy_attributes extension_type.td_attrs td_attrs type_heaps.th_attrs + type_heaps & th_vars = th_vars, th_attrs = th_attrs + # (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env [] type_heaps.th_attrs + (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs } + (fresh_args, type_heaps) = freshCopy st_args type_heaps + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + | isEmpty st_context + = ([fresh_args], result_type, attr_env, [], var_store, attr_store, type_heaps, all_exis_variables) + # (context, type_heaps) = freshTypeContexts_no_fresh_context_vars st_context type_heaps // fresh_context_vars are created later + = ([fresh_args], result_type, attr_env, [(glob_object,context)], var_store, attr_store, type_heaps, all_exis_variables) + fresh_symbol_types [{ap_symbol={glob_object,glob_module},ap_expr} : patterns] common_defs td_attrs td_args var_store attr_store type_heaps all_exis_variables + # (cons_types, result_type, attr_env, constructor_contexts, var_store, attr_store, type_heaps, all_exis_variables) + = fresh_symbol_types patterns common_defs td_attrs td_args var_store attr_store type_heaps all_exis_variables + # {cons_type = {st_args,st_attr_env,st_context}, cons_exi_vars,cons_number, cons_type_index} = common_defs.[glob_module].com_cons_defs.[glob_object.ds_index] + | cons_number <> -3 + # (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env attr_env type_heaps.th_attrs + (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs } + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + | isEmpty st_context + = ([fresh_args : cons_types], result_type, attr_env, constructor_contexts, var_store, attr_store, type_heaps, all_exis_variables) + # (context, type_heaps) = freshTypeContexts_no_fresh_context_vars st_context type_heaps // fresh_context_vars are created later + = ([fresh_args : cons_types], result_type, attr_env, [(glob_object,context):constructor_contexts], var_store, attr_store, type_heaps, all_exis_variables) + # extension_type = common_defs.[glob_module].com_type_defs.[cons_type_index] + th_vars = copy_type_variables extension_type.td_args td_args type_heaps.th_vars + th_attrs = copy_attributes extension_type.td_attrs td_attrs type_heaps.th_attrs + type_heaps & th_vars = th_vars, th_attrs = th_attrs + # (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env attr_env type_heaps.th_attrs + (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs } + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + | isEmpty st_context + = ([fresh_args : cons_types], result_type, attr_env, constructor_contexts, var_store, attr_store, type_heaps, all_exis_variables) + # (context, type_heaps) = freshTypeContexts_no_fresh_context_vars st_context type_heaps // fresh_context_vars are created later + = ([fresh_args : cons_types], result_type, attr_env, [(glob_object,context):constructor_contexts], var_store, attr_store, type_heaps, all_exis_variables) add_exis_variables expr [] exis_variables = exis_variables add_exis_variables expr new_exis_variables exis_variables = [(CP_Expression expr, new_exis_variables) : exis_variables] + copy_type_variables [dest_type_var:dest_type_vars] [source_type_var:source_type_vars] th_vars + # (tv_info/*TVI_Type (TempV type_var_number)*/,th_vars) = readPtr source_type_var.atv_variable.tv_info_ptr th_vars + # th_vars = writePtr dest_type_var.atv_variable.tv_info_ptr tv_info th_vars + = copy_type_variables dest_type_vars source_type_vars th_vars + copy_type_variables [] [] th_vars + = th_vars + + copy_attributes [dest_attr:dest_attrs] [source_attr:source_attrs] th_attrs + # (av_info/*AVI_Attr (TA_TempVar attr_number)*/,th_attrs) = readPtr source_attr.av_info_ptr th_attrs + # th_attrs = writePtr dest_attr.av_info_ptr av_info th_attrs + = copy_attributes dest_attrs source_attrs th_attrs + copy_attributes [] [] th_attrs + = th_attrs + +create_fresh_context_vars [(cons_symbol,contexts):constructor_contexts] var_heap + # (constructor_contexts,var_heap) = create_fresh_context_vars constructor_contexts var_heap + # (contexts,var_heap) = mapSt fresh_type_context_var contexts var_heap + = ([(cons_symbol,contexts):constructor_contexts],var_heap); +where + fresh_type_context_var tc var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ({tc & tc_var = new_info_ptr}, var_heap) +create_fresh_context_vars [] var_heap + = ([],var_heap) + fresh_overloaded_list_type [{ap_symbol}:patterns] pd_cons_symbol pd_nil_symbol decons_u_index nil_u_index stdStrictLists_index pos functions common_defs ts | ap_symbol.glob_module==cPredefinedModuleIndex | ap_symbol.glob_object.ds_index==pd_cons_symbol-FirstConstructorPredefinedSymbolIndex @@ -991,6 +1049,13 @@ where = ({ tc & tc_types = tc_types, tc_var = new_info_ptr }, (type_heaps, var_heap)) = ({ tc & tc_types = tc_types}, (type_heaps, var_heap)) +freshTypeContexts_no_fresh_context_vars tcs type_heaps + = mapSt fresh_type_context tcs type_heaps +where + fresh_type_context tc=:{tc_types} type_heaps + # (tc_types, type_heaps) = fresh_context_types tc_types type_heaps + = ({tc & tc_types = tc_types}, type_heaps) + fresh_context_types tc_types type_heaps = mapSt fresh_context_type tc_types type_heaps where @@ -1543,13 +1608,13 @@ where = ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = CP_Expression expr, tc_coercible = True } : reqs.req_type_coercions] }, { ts & ts_expr_heap = ts_expr_heap }) - update_case_variable (Var {var_ident,var_info_ptr,var_expr_ptr}) (RecordType {rt_constructor={ds_index}}) [cons_type] {glob_module} var_heap + update_case_variable (Var {var_ident,var_info_ptr}) (RecordType {rt_constructor={ds_index}}) [cons_type] {gi_module} var_heap # (var_info, var_heap) = readPtr var_info_ptr var_heap = case var_info of VI_Type type type_info - -> var_heap <:= (var_info_ptr, VI_Type type (VITI_PatternType cons_type glob_module ds_index type_info)) + -> var_heap <:= (var_info_ptr, VI_Type type (VITI_PatternType cons_type gi_module ds_index type_info)) VI_FAType vars type type_info - -> var_heap <:= (var_info_ptr, VI_FAType vars type (VITI_PatternType cons_type glob_module ds_index type_info)) + -> var_heap <:= (var_info_ptr, VI_FAType vars type (VITI_PatternType cons_type gi_module ds_index type_info)) _ -> abort "update_case_variable" // ---> (var_ident <<- var_info)) update_case_variable expr td_rhs cons_types alg_type var_heap |