Skip to content
GitLab
Commit fa652528 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

removed unused administrations

parent e818212d
Hide whitespace changes
Inline Side-by-side
frontend/convertDynamics.dcl
View file @ fa652528
......@@ -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)
frontend/convertDynamics.icl
View file @ fa652528
......@@ -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)
......
frontend/frontend.icl
View file @ fa652528
......@@ -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
......
frontend/overloading.dcl
View file @ fa652528
......@@ -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
......
frontend/overloading.icl
View file @ fa652528
......@@ -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
frontend/syntax.dcl
View file @ fa652528
......@@ -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)
......
frontend/syntax.icl
View file @ fa652528
......@@ -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)
......
frontend/type.dcl
View file @ fa652528
......@@ -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);
......
frontend/type.icl
View file @ fa652528
......@@ -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