diff options
| -rw-r--r-- | frontend/convertDynamics.dcl | 2 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 12 | ||||
| -rw-r--r-- | frontend/frontend.icl | 4 | ||||
| -rw-r--r-- | frontend/overloading.dcl | 8 | ||||
| -rw-r--r-- | frontend/overloading.icl | 148 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 4 | ||||
| -rw-r--r-- | frontend/syntax.icl | 4 | ||||
| -rw-r--r-- | frontend/type.dcl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 49 |
9 files changed, 83 insertions, 150 deletions
diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl index e00a065..2163b4d 100644 --- a/frontend/convertDynamics.dcl +++ b/frontend/convertDynamics.dcl @@ -8,5 +8,5 @@ import syntax, transform :: TypeCodeVariableInfo :: DynamicValueAliasInfo -convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule /* TD */ [String] +convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule /* TD */ [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, Optional *File) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 3259e6c..2a12842 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -102,9 +102,9 @@ f (Yes tcl_file) = tcl_file; 0.2*/ -convertDynamicPatternsIntoUnifyAppls :: {!GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule [String] +convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, (Optional *File)) -convertDynamicPatternsIntoUnifyAppls _ common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules +convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules #! (dynamic_representation,predefined_symbols) = create_dynamic_and_selector_idents common_defs predefined_symbols @@ -620,7 +620,7 @@ convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci) = (App {app_symb = typeapp_symb, app_args = [typecode_t, typecode_arg], app_info_ptr = nilPtr}, st) -convertTypeCode pattern cinp (TCE_Constructor index cons []) (has_var, binds, ci) +convertTypeCode pattern cinp (TCE_Constructor cons []) (has_var, binds, ci) # (typecons_symb, ci) = getSymbol PD_Dyn_TypeCons SK_Constructor 1 ci # (constructor, ci) @@ -647,7 +647,7 @@ where # predef_type_index = type_index + FirstTypePredefinedSymbolIndex = constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci - typeConstructor (GTT_Constructor cons_ident _) ci + typeConstructor (GTT_Constructor cons_ident) ci = (App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}, ci) typeConstructor (GTT_Basic basic_type) ci = constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci @@ -690,9 +690,9 @@ where = PD_Dyn_TypeCodeConstructor_UnboxedArray // otherwise = fatal "predefinedType" "TC code from predef" -convertTypeCode pattern cinp (TCE_Constructor index cons args) st +convertTypeCode pattern cinp (TCE_Constructor cons args) st # curried_type - = foldl TCE_App (TCE_Constructor index cons []) args + = foldl TCE_App (TCE_Constructor cons []) args = convertTypeCode pattern cinp curried_type st convertTypeCode pattern cinp (TCE_UniType uni_vars type_code) (has_var, binds, ci) # (tv_symb, ci) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 4915ffa..1cae9cc 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -150,7 +150,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an | not ok = (No,{},{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) - # (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out) + # (ok, fun_defs, array_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out) = typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs/*icl_functions*/ icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out dcl_mods | not ok @@ -166,7 +166,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances heaps # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, tcl_file) - = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols + = convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules | options.feo_up_to_phase == FrontEndPhaseConvertDynamics diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl index d89baac..3435fba 100644 --- a/frontend/overloading.dcl +++ b/frontend/overloading.dcl @@ -22,9 +22,6 @@ import syntax, check, typesupport , si_array_instances :: ![ArrayInstance] , si_list_instances :: ![ArrayInstance] , si_tail_strict_list_instances :: ![ArrayInstance] - , si_next_TC_member_index :: !Index - , si_TC_instances :: ![GlobalTCInstance] - , si_type_constructors_in_patterns :: ![Index] } :: OverloadingState = @@ -44,13 +41,10 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Ind -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState) :: TypeCodeInfo = - { tci_next_index :: !Index - , tci_instances :: ![GlobalTCInstance] - , tci_type_var_heap :: !.TypeVarHeap + { tci_type_var_heap :: !.TypeVarHeap , tci_attr_var_heap :: !.AttrVarHeap , tci_dcl_modules :: !{# DclModule} , tci_common_defs :: !{# CommonDefs } - , tci_type_constructors_in_patterns :: ![Index] } removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap diff --git a/frontend/overloading.icl b/frontend/overloading.icl index bea32b3..829f13b 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -23,8 +23,7 @@ import genericsupport, compilerSwitches, type_io_common } :: TypeCodeInstance = - { tci_index :: !Index - , tci_constructor :: !GlobalTCType + { tci_constructor :: !GlobalTCType , tci_contexts :: ![ClassApplication] } @@ -49,9 +48,6 @@ import genericsupport, compilerSwitches, type_io_common , si_array_instances :: ![ArrayInstance] , si_list_instances :: ![ArrayInstance] , si_tail_strict_list_instances :: ![ArrayInstance] - , si_next_TC_member_index :: !Index - , si_TC_instances :: ![GlobalTCInstance] - , si_type_constructors_in_patterns :: ![Index] } :: LocalTypePatternVariable = @@ -69,29 +65,6 @@ import genericsupport, compilerSwitches, type_io_common , os_error :: !.ErrorAdmin } -instance =< TypeSymbIdent -where - (=<) {type_index={glob_module=mod1,glob_object=index1}} {type_index={glob_module=mod2,glob_object=index2}} - # cmp = mod1 =< mod2 - | cmp == Equal - = index1 =< index2 - = cmp - -instance =< GlobalTCType -where - (=<) globtype1 globtype2 - | equal_constructor globtype1 globtype2 - = compare_types globtype1 globtype2 - | less_constructor globtype1 globtype2 - = Smaller - = Greater - where - compare_types (GTT_Basic bt1) (GTT_Basic bt2) - = bt1 =< bt2 - compare_types (GTT_Constructor cons1 _) (GTT_Constructor cons2 _) - = cons1 =< cons2 - compare_types _ _ - = Equal instanceError symbol types err # err = errorHeading "Overloading error" err @@ -119,7 +92,7 @@ overloadingError op_symb err Yes (str, line_nr) -> str+++" [line "+++toString line_nr+++"]" = { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< str <<< "\" could not be solved\n" } - + abstractTypeInDynamicError td_ident err=:{ea_ok} # err = errorHeading "Implementation restriction" err = { err & ea_file = err.ea_file <<< (" derived abstract type '" +++ toString td_ident +++ "' not permitted in a dynamic") <<< '\n' } @@ -181,8 +154,8 @@ where reduce_any_context tc=:{tc_class=class_symb=:(TCClass {glob_object={ds_index},glob_module}),tc_types} defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error | is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols - # (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps,error)) - = reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap type_heaps error + # (red_context, (new_contexts, type_pattern_vars, var_heap, type_heaps,error)) + = reduce_TC_context class_symb (hd tc_types) new_contexts type_pattern_vars var_heap type_heaps error = (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) # (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) = reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars @@ -550,53 +523,45 @@ where AbstractSynType _ _ -> abstractTypeInDynamicError td_ident error _ -> error - reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap type_heaps error - = reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error) + reduce_TC_context type_code_class tc_type new_contexts type_pattern_vars var_heap type_heaps error + = reduce_tc_context type_code_class tc_type (new_contexts, type_pattern_vars, var_heap, type_heaps, error) where - reduce_tc_context type_code_class type=:(TA cons_id=:{type_index} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error) + reduce_tc_context type_code_class type=:(TA cons_id=:{type_index} cons_args) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) # error = disallow_abstract_types_in_dynamics type_index error # (expanded, type, type_heaps) = tryToExpandTypeSyn defs type cons_id cons_args type_heaps | expanded - = reduce_tc_context type_code_class type (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error) + = reduce_tc_context type_code_class type (new_contexts, type_pattern_vars, var_heap, type_heaps, error) # type_constructor = toTypeCodeConstructor type_index defs - # (inst_index, (si_next_TC_member_index, si_TC_instances)) - = addGlobalTCInstance type_constructor (si_next_TC_member_index, si_TC_instances) (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args - (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error) - = (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances) - reduce_tc_context type_code_class (TAS cons_id=:{type_index} cons_args _) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error) + (new_contexts, type_pattern_vars, var_heap, type_heaps, error) + = (CA_GlobalTypeCode { tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances) + reduce_tc_context type_code_class (TAS cons_id=:{type_index} cons_args _) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) # error = disallow_abstract_types_in_dynamics type_index error # type_constructor = toTypeCodeConstructor type_index defs - # (inst_index, (si_next_TC_member_index, si_TC_instances)) - = addGlobalTCInstance type_constructor (si_next_TC_member_index, si_TC_instances) (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args - (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error) - = (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances) - reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error) - # (inst_index, (si_next_TC_member_index, si_TC_instances)) - = addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances) - = (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = GTT_Basic basic_type, tci_contexts = [] }, - (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error)) - reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap, type_heaps, error) - # (inst_index, (si_next_TC_member_index, si_TC_instances)) - = addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances) - (rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type] - (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap, type_heaps, error) - = (CA_GlobalTypeCode { tci_index = inst_index, tci_constructor = GTT_Function, tci_contexts = rc_red_contexts }, instances) - reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error) + (new_contexts, type_pattern_vars, var_heap, type_heaps, error) + = (CA_GlobalTypeCode { tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, instances) + reduce_tc_context type_code_class (TB basic_type) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) + = (CA_GlobalTypeCode { tci_constructor = GTT_Basic basic_type, tci_contexts = [] }, + (new_contexts, type_pattern_vars, var_heap, type_heaps, error)) + reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) + # (rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type] + (new_contexts, type_pattern_vars, var_heap, type_heaps, error) + = (CA_GlobalTypeCode { tci_constructor = GTT_Function, tci_contexts = rc_red_contexts }, instances) + reduce_tc_context type_code_class (TempQV var_number) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) # (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap) - = (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)) - reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error) + = (CA_LocalTypeCode inst_var, (new_contexts, type_pattern_vars, var_heap, type_heaps, error)) + reduce_tc_context type_code_class (TempV var_number) (new_contexts, type_pattern_vars, var_heap, type_heaps, error) # (tc_var, var_heap) = newPtr VI_Empty var_heap tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var } | containsContext tc new_contexts - = (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap, type_heaps, error)) - = (CA_Context tc, ([tc : new_contexts], special_instances, type_pattern_vars, var_heap, type_heaps, error)) + = (CA_Context tc, (new_contexts, type_pattern_vars, var_heap, type_heaps, error)) + = (CA_Context tc, ([tc : new_contexts], type_pattern_vars, var_heap, type_heaps, error)) reduce_TC_contexts type_code_class cons_args instances = mapSt (\{at_type} -> reduce_tc_context type_code_class at_type) cons_args instances @@ -614,17 +579,6 @@ addLocalTCInstance var_number ([], ltp_var_heap) # (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap = (ltpv_new_var, ([{ ltpv_new_var = ltpv_new_var, ltpv_var = var_number }], ltp_var_heap)) -addGlobalTCInstance type_of_TC (next_member_index, instances=:[inst : insts]) - # cmp = type_of_TC =< inst.gtci_type - | cmp == Equal - = (inst.gtci_index, (next_member_index, instances)) - | cmp == Smaller - = (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC } : instances ])) - # (found_inst, (next_member_index, insts)) = addGlobalTCInstance type_of_TC (next_member_index, insts) - = (found_inst, (next_member_index, [inst : insts])) -addGlobalTCInstance type_of_TC (next_member_index, []) - = (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC }])) - tryToExpandTypeSyn defs type cons_id=:{type_ident,type_index={glob_object,glob_module}} type_args type_heaps # {td_ident,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of @@ -912,9 +866,9 @@ where selector = selectFromDictionary glob_module ds_index me_offset defs = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs, ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs)) - adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_index,tci_constructor,tci_contexts}) _ heaps_and_ptrs + adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs - = (EI_TypeCode (TCE_Constructor tci_index tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs) + = (EI_TypeCode (TCE_Constructor tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs) adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs = (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs) @@ -974,9 +928,9 @@ where = (Selection NormalSelector (ClassVariable class_context.tc_var) (generateClassSelection context_address []), ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs)) convert_class_appl_to_expression defs contexts (CA_LocalTypeCode new_var_ptr) heaps_and_ptrs = (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs) - convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_index,tci_constructor,tci_contexts}) heaps_and_ptrs + convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs - = (TypeCodeExpression (TCE_Constructor tci_index tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs) + = (TypeCodeExpression (TCE_Constructor tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs) convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs # (rcs_exprs, heaps_and_ptrs) = mapSt (convert_reduced_contexts_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs @@ -1293,9 +1247,9 @@ where = (new_var_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var new_var_ptr)), var_heap)) updateFreeVarsOfTCE :: !Ident !TypeCodeExpression (!*VarHeap, !*ErrorAdmin) -> (!TypeCodeExpression, !(!*VarHeap, *ErrorAdmin)) -updateFreeVarsOfTCE symb_ident (TCE_Constructor type_index type_cons type_args) var_heap_and_error +updateFreeVarsOfTCE symb_ident (TCE_Constructor type_cons type_args) var_heap_and_error # (type_args, var_heap_and_error) = mapSt (updateFreeVarsOfTCE symb_ident) type_args var_heap_and_error - = (TCE_Constructor type_index type_cons type_args, var_heap_and_error) + = (TCE_Constructor type_cons type_args, var_heap_and_error) updateFreeVarsOfTCE symb_ident (TCE_Selector selections var_info_ptr) var_heap_and_error # (var_info_ptr, var_heap_and_error) = getTCDictionary symb_ident var_info_ptr var_heap_and_error = (TCE_Selector selections var_info_ptr, var_heap_and_error) @@ -1314,13 +1268,10 @@ getTCDictionary symb_ident var_info_ptr (var_heap, error) -> (var_info_ptr, (var_heap, overloadingError symb_ident error)) :: TypeCodeInfo = - { tci_next_index :: !Index - , tci_instances :: ![GlobalTCInstance] - , tci_type_var_heap :: !.TypeVarHeap + { tci_type_var_heap :: !.TypeVarHeap , tci_attr_var_heap :: !.AttrVarHeap , tci_dcl_modules :: !{# DclModule} , tci_common_defs :: !{# CommonDefs } - , tci_type_constructors_in_patterns :: ![Index] } @@ -1346,7 +1297,7 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c = { symb_ident = ds_ident , symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index} } - = GTT_Constructor type_constructor False + = GTT_Constructor type_constructor fatal :: {#Char} {#Char} -> .a fatal function_name message @@ -1355,7 +1306,7 @@ fatal function_name message class toTypeCodeExpression type :: type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin) -> (!TypeCodeExpression, !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin)) instance toTypeCodeExpression Type where - toTypeCodeExpression type=:(TA cons_id=:{type_index} type_args) (tci=:{tci_next_index,tci_instances,tci_dcl_modules,tci_common_defs},var_heap,error) + toTypeCodeExpression type=:(TA cons_id=:{type_index} type_args) (tci=:{tci_dcl_modules,tci_common_defs},var_heap,error) # type_heaps = {th_vars = tci.tci_type_var_heap, th_attrs = tci.tci_attr_var_heap} # (expanded, type, type_heaps) @@ -1366,22 +1317,16 @@ instance toTypeCodeExpression Type where = toTypeCodeExpression type (tci,var_heap,error) # type_constructor = toTypeCodeConstructor type_index tci_common_defs - # (inst_index, (tci_next_index, tci_instances)) - = addGlobalTCInstance type_constructor (tci_next_index, tci_instances) (type_code_args, tci) - = mapSt (toTypeCodeExpression) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) - = (TCE_Constructor inst_index type_constructor type_code_args, tci) + = mapSt (toTypeCodeExpression) type_args (tci,var_heap,error) + = (TCE_Constructor type_constructor type_code_args, tci) toTypeCodeExpression (TAS cons_id type_args _) state = toTypeCodeExpression (TA cons_id type_args) state - toTypeCodeExpression (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error) - # (inst_index, (tci_next_index, tci_instances)) - = addGlobalTCInstance (GTT_Basic basic_type) (tci_next_index, tci_instances) - = (TCE_Constructor inst_index (GTT_Basic basic_type) [], ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)) - toTypeCodeExpression (arg_type --> result_type) (tci=:{tci_next_index,tci_instances},var_heap,error) - # (inst_index, (tci_next_index, tci_instances)) - = addGlobalTCInstance GTT_Function (tci_next_index, tci_instances) - (type_code_args, tci) = mapSt (toTypeCodeExpression) [arg_type, result_type] ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) - = (TCE_Constructor inst_index GTT_Function type_code_args, tci) + toTypeCodeExpression (TB basic_type) (tci,var_heap,error) + = (TCE_Constructor (GTT_Basic basic_type) [], (tci,var_heap,error)) + toTypeCodeExpression (arg_type --> result_type) (tci,var_heap,error) + # (type_code_args, tci) = mapSt (toTypeCodeExpression) [arg_type, result_type] (tci,var_heap,error) + = (TCE_Constructor GTT_Function type_code_args, tci) toTypeCodeExpression (TV var) st = toTypeCodeExpression var st toTypeCodeExpression (TFA vars type) (tci=:{tci_type_var_heap}, var_heap, error) @@ -1702,14 +1647,11 @@ where # ui = { ui & ui_var_heap = ui_var_heap, ui_error = ui_error} = (TCE_TypeTerm var_info_ptr, ui) - adjust_type_code (TCE_Constructor index cons typecode_exprs) - ui=:{ui_x={x_type_code_info={tci_type_constructors_in_patterns} }} - # ui - = { ui & ui_x.x_type_code_info.tci_type_constructors_in_patterns = - [index:tci_type_constructors_in_patterns] } + adjust_type_code (TCE_Constructor cons typecode_exprs) + ui # (typecode_exprs, ui) = mapSt adjust_type_code typecode_exprs ui - = (TCE_Constructor index cons typecode_exprs, ui) + = (TCE_Constructor cons typecode_exprs, ui) adjust_type_code (TCE_UniType uni_vars type_code) ui # (type_code, ui) = adjust_type_code type_code ui @@ -1848,5 +1790,5 @@ where instance <<< TypeCodeInstance where - (<<<) file {tci_index, tci_contexts} = file <<< tci_index <<< ' ' <<< tci_contexts + (<<<) file {tci_contexts} = file <<< ' ' <<< tci_contexts diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 9c6b56d..6f746cd 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1273,12 +1273,12 @@ instance == OverloadedListType :: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_TypeTerm !VarInfoPtr - | TCE_Constructor !Index !GlobalTCType ![TypeCodeExpression] + | TCE_Constructor !GlobalTCType ![TypeCodeExpression] | TCE_App !TypeCodeExpression !TypeCodeExpression | TCE_Selector ![Selection] !VarInfoPtr | TCE_UniType ![VarInfoPtr] !TypeCodeExpression -:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !SymbIdent !Bool | GTT_PredefTypeConstructor !(Global Index) | GTT_Function +:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !SymbIdent | GTT_PredefTypeConstructor !(Global Index) | GTT_Function :: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar) diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ba7de81..75ddda5 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -436,8 +436,8 @@ where = file <<< "TCE_Var " <<< info_ptr (<<<) file (TCE_TypeTerm info_ptr) = file <<< "TCE_TypeTerm " <<< info_ptr - (<<<) file (TCE_Constructor index cons exprs) - = file <<< "TCE_Constructor " <<< index <<< ' ' <<< exprs + (<<<) file (TCE_Constructor cons exprs) + = file <<< "TCE_Constructor " <<< ' ' <<< exprs (<<<) file (TCE_Selector selectors info_ptr) = file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr (<<<) file (TCE_UniType vars type_code) diff --git a/frontend/type.dcl b/frontend/type.dcl index 4e64092..57428ea 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -4,7 +4,7 @@ import StdArray import syntax, check typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} - -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) + -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState); diff --git a/frontend/type.icl b/frontend/type.icl index 86dd0b7..9c679f1 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1865,12 +1865,18 @@ possibly_accumulate_reqs_in_new_group position state_transition reqs_ts req_type_coercions = old_req_type_coercions } = (reqs_with_new_group, ts) -makeBase _ _ [] [] ts_var_heap +makeBase id=:{id_name} a l1 l2 vh + | length l1 <> length l2 + = abort ("makeBase!!! " +++ id_name +++ toString (length l1) +++ toString (length l2)) + // otherwise + = makeBase2 id a l1 l2 vh + +makeBase2 _ _ [] [] ts_var_heap = ts_var_heap -makeBase fun_or_cons_ident arg_nr [{fv_ident, fv_info_ptr} : vars] [type : types] ts_var_heap +makeBase2 fun_or_cons_ident arg_nr [{fv_ident, fv_info_ptr} : vars] [type : types] ts_var_heap | is_rare_name fv_ident - = makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type (VITI_Coercion (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap) - = makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type VITI_Empty ts_var_heap) + = makeBase2 fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type (VITI_Coercion (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap) + = makeBase2 fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type VITI_Empty ts_var_heap) addToBase info_ptr atype=:{at_type = TFA atvs type} optional_position ts_var_heap = ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type} optional_position) @@ -2213,7 +2219,7 @@ ste_kind_to_string s */ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} - -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) + -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers td_infos heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap} predef_symbols file out dcl_modules #! fun_env_size = size fun_defs @@ -2231,13 +2237,13 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_generic_heap = hp_generic_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_fun_defs=fun_defs } ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n } - special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_list_instances = [], si_tail_strict_list_instances = [], si_next_TC_member_index = 0, si_TC_instances = [], si_type_constructors_in_patterns = [] } + special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_list_instances = [], si_tail_strict_list_instances = [] } # (type_error, predef_symbols, special_instances, out, ts) = type_components list_inferred_types 0 comps class_instances ti (False, predef_symbols, special_instances, out, ts) (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env ts.ts_fun_defs (type_error, predef_symbols, special_instances,out, {ts_td_infos,ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps, ts_generic_heap,ts_fun_defs}) = type_instances list_inferred_types specials.ir_from specials.ir_to class_instances ti (type_error, predef_symbols, special_instances, out, { ts & ts_fun_env = ts_fun_env,ts_fun_defs=fun_defs }) - (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,ts_type_heaps,ts_error) + (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,predef_symbols,ts_type_heaps,ts_error) = create_special_instances special_instances fun_env_size ti_common_defs ts_fun_defs predef_symbols ts_type_heaps ts_error array_and_list_instances = { ali_array_first_instance_indices=array_first_instance_indices, @@ -2246,7 +2252,7 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de ali_instances_range={ ir_from = fun_env_size, ir_to = special_instances.si_next_array_member_index } } # ts_var_heap = clear_var_heap ti_functions ts_var_heap - = (not type_error, fun_defs, array_and_list_instances, type_code_instances, ti_common_defs, ti_functions, + = (not type_error, fun_defs, array_and_list_instances, ti_common_defs, ti_functions, ts_td_infos, {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps, hp_generic_heap=ts_generic_heap }, predef_symbols, ts_error.ea_file, out) // ---> ("typeProgram", array_inst_types) @@ -2419,27 +2425,24 @@ where { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_error = { ts.ts_error & ea_ok = True }}) | isEmpty over_info # ts_type_heaps = ts.ts_type_heaps - type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, - tci_type_var_heap = ts_type_heaps.th_vars, tci_attr_var_heap = ts_type_heaps.th_attrs, - tci_dcl_modules = dcl_modules, tci_common_defs = ti_common_defs, - tci_type_constructors_in_patterns = os_special_instances.si_type_constructors_in_patterns } - # (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap,tci_attr_var_heap,tci_type_constructors_in_patterns}, ts_var_heap, ts_error, os_predef_symbols) + type_code_info = { tci_type_var_heap = ts_type_heaps.th_vars, tci_attr_var_heap = ts_type_heaps.th_attrs, + tci_dcl_modules = dcl_modules, tci_common_defs = ti_common_defs } + # (fun_defs, ts_fun_env, ts_expr_heap, {tci_type_var_heap,tci_attr_var_heap}, ts_var_heap, ts_error, os_predef_symbols) = updateDynamics comp local_pattern_variables main_dcl_module_n ts.ts_fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, - os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances, si_type_constructors_in_patterns = tci_type_constructors_in_patterns }, out, + os_predef_symbols, os_special_instances, out, { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap, th_attrs = tci_attr_var_heap }, ts_fun_env = ts_fun_env, ts_fun_defs=fun_defs}) # ts_type_heaps = ts.ts_type_heaps - type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, tci_type_constructors_in_patterns = os_special_instances.si_type_constructors_in_patterns, - tci_type_var_heap = ts_type_heaps.th_vars, tci_attr_var_heap = ts_type_heaps.th_attrs, + type_code_info = { tci_type_var_heap = ts_type_heaps.th_vars, tci_attr_var_heap = ts_type_heaps.th_attrs, tci_dcl_modules = dcl_modules, tci_common_defs = ti_common_defs } - (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap,tci_attr_var_heap, tci_type_constructors_in_patterns}, ts_var_heap, ts_error, os_predef_symbols) + (fun_defs, ts_fun_env, ts_expr_heap, {tci_type_var_heap,tci_attr_var_heap}, ts_var_heap, ts_error, os_predef_symbols) = removeOverloadedFunctions comp local_pattern_variables main_dcl_module_n ts.ts_fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, - os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances, si_type_constructors_in_patterns = tci_type_constructors_in_patterns }, out, + os_predef_symbols, os_special_instances, out, { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap, th_attrs = tci_attr_var_heap }, @@ -2680,7 +2683,7 @@ where type_of (UncheckedType tst) = tst type_of (SpecifiedType _ _ tst) = tst - create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index,si_next_TC_member_index,si_TC_instances,si_type_constructors_in_patterns} fun_env_size common_defs fun_defs predef_symbols type_heaps error + create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index} fun_env_size common_defs fun_defs predef_symbols type_heaps error # fun_defs = add_extra_elements_to_fun_def_array (si_next_array_member_index-fun_env_size) fun_defs with add_extra_elements_to_fun_def_array n_new_elements fun_defs @@ -2695,15 +2698,9 @@ where = convert_list_instances si_list_instances PD_UListClass common_defs fun_defs predef_symbols type_heaps error (tail_strict_list_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) = convert_list_instances si_tail_strict_list_instances PD_UTSListClass common_defs fun_defs predef_symbols type_heaps error - type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = mark_used_type_constructors_in_applications_of_type_dependent_functions gtci \\ gtci=:{gtci_index, gtci_type} <- si_TC_instances} array_first_instance_indices = first_instance_indices si_array_instances - = (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,type_heaps,error) + = (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,predef_symbols,type_heaps,error) where - mark_used_type_constructors_in_applications_of_type_dependent_functions {gtci_index, gtci_type=GTT_Constructor cons False} - = GTT_Constructor cons True - mark_used_type_constructors_in_applications_of_type_dependent_functions {gtci_type} - = gtci_type - convert_array_instances array_instances common_defs fun_defs predef_symbols type_heaps error | isEmpty array_instances = ([],fun_defs, predef_symbols, type_heaps, error) |