Commit 05360070 authored by John van Groningen's avatar John van Groningen
Browse files

refactor, change type of field fun_type from Optional SymbolType to new...

refactor, change type of field fun_type from Optional SymbolType to new algebraic type FunDefType (so a new constructor can be added later)
parent b16bf1f0
......@@ -634,7 +634,7 @@ declareGeneratedUnboxedRecordInstancesOfClass ali_first_instance_indices predef_
= declareInstances (member_n+1) n_class_members first_member_index backend
declareInstance :: Index FunDef -> BackEnder
declareInstance index {fun_ident={id_name}, fun_type=Yes type}
declareInstance index {fun_ident={id_name}, fun_type=FunDefType type}
= beDeclareRuleType index main_dcl_module_n (id_name +++ ";" +++ toString index)
o` beDefineRuleType index main_dcl_module_n (convertTypeAlt index main_dcl_module_n type array_dictionary_index)
......@@ -1456,7 +1456,7 @@ convertRules rules main_dcl_module_n aliasDummyId array_dictionary_index be
= convert t rulesP be
convertRule :: Ident (Int,FunDef) Int GlobalIndex !*BackEndState -> *(!BEImpRuleP,!*BackEndState)
convertRule aliasDummyId (index,{fun_type=Yes type,fun_body=body,fun_pos,fun_kind,fun_info})
convertRule aliasDummyId (index,{fun_type=FunDefType type,fun_body=body,fun_pos,fun_kind,fun_info})
main_dcl_module_n array_dictionary_index bes
| fun_info.fi_properties bitand FI_FusedMember<>0
#! instance_function_index = fun_info.fi_def_level;
......
......@@ -122,7 +122,7 @@ printFunctionTypes all attr info components functions attrHeap file backEnd
= function_indices_and_functions (i+1) components
printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap, *File, *BackEnd) -> (*AttrVarHeap, *File, *BackEnd)
printFunctionType all attr info (functionIndex, {fun_ident,fun_type=Yes type}) (attrHeap, file, backEnd)
printFunctionType all attr info (functionIndex, {fun_ident,fun_type=FunDefType type}) (attrHeap, file, backEnd)
| not all && functionIndex >= size info.dtci_dclModules.[info.dtci_iclModuleIndex].dcl_functions
= (attrHeap, file, backEnd)
......
......@@ -1172,11 +1172,11 @@ where
# ({fun_type,fun_ident,fun_info,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index]
(expression_heap,class_infos,as) = check_kinds_of_dynamics common_defs fun_info.fi_dynamics expression_heap class_infos as
= case fun_type of
Yes symbol_type
# as_error = pushErrorPosition fun_ident fun_pos as.as_error
(class_infos, as) = check_kinds_of_symbol_type common_defs symbol_type class_infos { as & as_error = as_error }
-> (icl_fun_defs, class_infos, expression_heap, { as & as_error = popErrorAdmin as.as_error })
No
FunDefType symbol_type
# as & as_error = pushErrorPosition fun_ident fun_pos as.as_error
(class_infos, as) = check_kinds_of_symbol_type common_defs symbol_type class_infos as
-> (icl_fun_defs, class_infos, expression_heap, {as & as_error = popErrorAdmin as.as_error})
NoFunDefType
-> (icl_fun_defs, class_infos, expression_heap, as)
check_kinds_of_dcl_fuctions common_defs module_index dcl_modules class_infos as
......
......@@ -484,7 +484,7 @@ where
= make_default_instance_body arity mm_ident me_priority ins_pos class_member function_n cs
new_instance_member
= { fun_ident = new_instance_member_ds.cim_ident, fun_arity = arity, fun_priority = me_priority,
fun_body = new_instance_body, fun_type = No, fun_pos = ins_pos,
fun_body = new_instance_body, fun_type = NoFunDefType, fun_pos = ins_pos,
fun_kind = FK_Function False, fun_lifted = 0, fun_info = EmptyFunInfo }
= (new_instance_member_ds,new_instance_member,ins_member_types_and_functions,cs)
make_default_implementation (DeriveDefault generic_ident generic_index optional_member_ident_global_index) me_priority ins_pos class_member function_n arity instance_member_n ins_member_types_and_functions cs
......@@ -500,7 +500,7 @@ where
fun_info = {EmptyFunInfo & fi_properties=FI_DefaultMemberWithDerive}
new_instance_member
= { fun_ident = new_instance_member_ds.cim_ident, fun_arity = arity, fun_priority = me_priority,
fun_body = new_instance_body, fun_type = No, fun_pos = ins_pos,
fun_body = new_instance_body, fun_type = NoFunDefType, fun_pos = ins_pos,
fun_kind = FK_Function False, fun_lifted = 0, fun_info = fun_info }
= (new_instance_member_ds,new_instance_member,ins_member_types_and_functions,cs)
......@@ -575,7 +575,7 @@ where
(argument_pointers,symbol_table) = make_argument_pointers arity [] cs.cs_symbol_table
cs & cs_symbol_table=symbol_table
new_instance_member = { fun_ident = new_instance_ident, fun_arity = arity, fun_priority = me_priority,
fun_body = fun_body, fun_type = No, fun_pos = ins_pos,
fun_body = fun_body, fun_type = NoFunDefType, fun_pos = ins_pos,
fun_kind = FK_Function False, fun_lifted = 0, fun_info = EmptyFunInfo }
= (new_instance_member_ds,new_instance_member,cs)
......@@ -1186,23 +1186,23 @@ checkFunction fun_def=:{fun_ident,fun_pos,fun_body,fun_type,fun_kind,fun_info={f
{heaps & hp_var_heap = es_var_heap, hp_expression_heap = es_expr_heap, hp_type_heaps = es_type_heaps,hp_generic_heap=es_generic_heap},
{cs & cs_symbol_table = cs_symbol_table})
where
has_type (Yes _) = FI_HasTypeSpec
has_type no = 0
has_type NoFunDefType = 0
has_type _ = FI_HasTypeSpec
check_function_type (Yes ft) module_index is_caf type_defs class_defs modules var_heap type_heaps cs
check_function_type (FunDefType ft) module_index is_caf type_defs class_defs modules var_heap type_heaps cs
# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkFunctionType module_index ft FSP_None type_defs class_defs modules type_heaps cs
cs = (if is_caf (check_caf_uniqueness ft.st_result.at_attribute) id) cs
cs = if is_caf (check_caf_uniqueness ft.st_result.at_attribute cs) cs
(st_context, var_heap) = initializeContextVariables ft.st_context var_heap
= (Yes { ft & st_context = st_context } , type_defs, class_defs, modules, var_heap, type_heaps, cs)
where
check_caf_uniqueness TA_None cs
= cs
check_caf_uniqueness TA_Multi cs
= cs
check_caf_uniqueness _ cs
= {cs & cs_error = checkError "result type of CAF must be non-unique " "" cs.cs_error}
check_function_type No module_index _ type_defs class_defs modules var_heap type_heaps cs
= (No, type_defs, class_defs, modules, var_heap, type_heaps, cs)
= (FunDefType {ft & st_context = st_context}, type_defs, class_defs, modules, var_heap, type_heaps, cs)
check_function_type NoFunDefType module_index _ type_defs class_defs modules var_heap type_heaps cs
= (NoFunDefType, type_defs, class_defs, modules, var_heap, type_heaps, cs)
check_caf_uniqueness TA_None cs
= cs
check_caf_uniqueness TA_Multi cs
= cs
check_caf_uniqueness _ cs
= {cs & cs_error = checkError "result type of CAF must be non-unique " "" cs.cs_error}
remove_calls_from_symbol_table fun_index fun_level [FunCall fc_index fc_level : fun_calls] fun_defs macro_defs symbol_table
| fc_level <= fun_level
......@@ -2455,7 +2455,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
add_dummy_functions n_functions icl_functions
| n_functions==0
= icl_functions
# dummy_function = {fun_ident={id_name="",id_info=nilPtr},fun_arity= -1,fun_priority=NoPrio,fun_body=NoBody,fun_type=No,fun_pos=NoPos,fun_kind=FK_Unknown,fun_lifted=0,fun_info=EmptyFunInfo}
# dummy_function = {fun_ident={id_name="",id_info=nilPtr},fun_arity= -1,fun_priority=NoPrio,fun_body=NoBody,fun_type=NoFunDefType,fun_pos=NoPos,fun_kind=FK_Unknown,fun_lifted=0,fun_info=EmptyFunInfo}
= arrayPlusList icl_functions [dummy_function \\ i<-[0..n_functions-1]]
add_dcl_instances_generic_cases_and_type_funs_to_conversion_table :: !{#Int} !Int !Int !Index IndexRange /*IndexRange*/ !DclModule
......@@ -3180,7 +3180,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
symb_kind = SK_Function { glob_module = main_dcl_module_n, glob_object = fun_index }},
app_args = app_args,
app_info_ptr = app_info_ptr }
= ({ fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = Yes fun_type,
= ({ fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = FunDefType fun_type,
fun_info = { EmptyFunInfo & fi_calls = [FunCall fun_index cGlobalScope] }},
(var_heap, type_var_heap, expr_heap))
......@@ -3199,29 +3199,29 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
# (fun_type,icl_functions) = icl_functions![index_of_member_fun].fun_type
# (icl_functions, type_heaps, cs_error)
= case fun_type of
No
# icl_functions = {icl_functions & [index_of_member_fun].fun_type = Yes derived_symbol_type}
NoFunDefType
# icl_functions & [index_of_member_fun].fun_type = FunDefType derived_symbol_type
-> (icl_functions, type_heaps, cs_error)
Yes specified_symbol_type
FunDefType specified_symbol_type
| not cs_error.ea_ok
# icl_functions = {icl_functions & [index_of_member_fun].fun_type = Yes derived_symbol_type}
# icl_functions & [index_of_member_fun].fun_type = FunDefType derived_symbol_type
-> (icl_functions, type_heaps, cs_error)
# (err_code, type_heaps)
= compare_specified_and_derived_instance_types specified_symbol_type derived_symbol_type type_heaps
| err_code==CEC_Ok
# icl_functions = {icl_functions & [index_of_member_fun].fun_type = Yes derived_symbol_type}
# icl_functions & [index_of_member_fun].fun_type = FunDefType derived_symbol_type
-> (icl_functions, type_heaps, cs_error)
| err_code==CEC_OkWithFirstMoreStrictness
# (function,icl_functions) = icl_functions![index_of_member_fun]
# function = {function & fun_type = Yes specified_symbol_type,
fun_info.fi_properties = function.fun_info.fi_properties bitor FI_MemberInstanceRequiresTypeInDefMod}
# function & fun_type = FunDefType specified_symbol_type,
fun_info.fi_properties = function.fun_info.fi_properties bitor FI_MemberInstanceRequiresTypeInDefMod
# icl_functions = {icl_functions & [index_of_member_fun] = function}
-> (icl_functions, type_heaps, cs_error)
# ({fun_ident,fun_pos},icl_functions) = icl_functions![index_of_member_fun]
cs_error = pushErrorPosition fun_ident fun_pos cs_error
cs_error = specified_member_type_incorrect_error err_code cs_error
cs_error = popErrorAdmin cs_error
icl_functions = {icl_functions & [index_of_member_fun].fun_type = Yes derived_symbol_type}
icl_functions & [index_of_member_fun].fun_type = FunDefType derived_symbol_type
-> (icl_functions, type_heaps, cs_error)
= (icl_functions, type_heaps, cs_error)
......@@ -3263,9 +3263,9 @@ checkForeignExports [{pfe_ident=pfe_ident=:{id_name,id_info},pfe_line,pfe_file,p
| ste_index>=ir_from && ste_index<ir_to
# ({fun_type,fun_ident,fun_pos},fun_defs) = fun_defs![ste_index]
# (foreign_export_fundef_index,cs) = case fun_type of
No
NoFunDefType
-> ([],cs)
Yes {st_args,st_args_strictness,st_arity,st_result,st_context}
FunDefType {st_args,st_args_strictness,st_arity,st_result,st_context}
| not (isEmpty st_context)
-> ([],{cs & cs_error = checkErrorWithPosition fun_ident fun_pos "error in type of foreign exported function (context not allowed)" cs.cs_error})
| not (first_n_are_strict st_arity st_args_strictness)
......@@ -3296,7 +3296,7 @@ checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admi
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
where
({fun_type=Yes {st_args,st_result},fun_ident,fun_pos},fun_defs2) = fun_defs![fe_fd_index]
({fun_type=FunDefType {st_args,st_result},fun_ident,fun_pos},fun_defs2) = fun_defs![fe_fd_index]
check_foreign_export_types [{at_type}:argument_types]
= check_foreign_export_type at_type && check_foreign_export_types argument_types
......
......@@ -489,7 +489,7 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
# fun_def =
{ fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
, fun_arity = 0, fun_priority = NoPrio
, fun_body = GeneratedBody, fun_type = No
, fun_body = GeneratedBody, fun_type = NoFunDefType
, fun_pos = gc_pos, fun_kind = FK_Unknown
, fun_lifted = 0, fun_info = EmptyFunInfo
}
......@@ -552,7 +552,7 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
# fun_def = {
fun_ident = genericIdentToFunIdent ds_ident.id_name type_cons,
fun_arity = 0, fun_priority = NoPrio,
fun_body = GeneratedBody, fun_type = No,
fun_body = GeneratedBody, fun_type = NoFunDefType,
fun_pos = pos, fun_kind = FK_Unknown,
fun_lifted = 0, fun_info = EmptyFunInfo
}
......@@ -578,7 +578,7 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
# fun_def = {
fun_ident = genericIdentToFunIdent ds_ident.id_name type_cons,
fun_arity = 0, fun_priority = NoPrio,
fun_body = GeneratedBody, fun_type = No,
fun_body = GeneratedBody, fun_type = NoFunDefType,
fun_pos = pos, fun_kind = FK_Unknown,
fun_lifted = 0, fun_info = EmptyFunInfo
}
......
......@@ -18,7 +18,7 @@ checkInstanceType :: !Index !GlobalIndex !ClassIdent !ClassArgs !InstanceType !S
checkSuperClasses :: !ClassArgs ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!ClassArgs, ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType)
checkDynamicTypes :: !Index ![ExprInfoPtr] !FunDefType
!u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*ExpressionHeap,!*CheckState)
......
......@@ -1427,10 +1427,10 @@ where
= { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_ident cs_symbol_table,
cs_error = checkError av_ident "attribute variable in context undefined" cs_error}
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType)
checkDynamicTypes :: !Index ![ExprInfoPtr] !FunDefType
!u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*ExpressionHeap,!*CheckState)
checkDynamicTypes mod_index dyn_type_ptrs No type_defs class_defs modules type_heaps expr_heap cs
checkDynamicTypes mod_index dyn_type_ptrs NoFunDefType type_defs class_defs modules type_heaps expr_heap cs
# (type_defs, class_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs class_defs modules type_heaps expr_heap cs
(expr_heap, cs_symbol_table) = remove_global_type_variables_in_dynamics dyn_type_ptrs (expr_heap, cs.cs_symbol_table)
= (type_defs, class_defs, modules, heaps, expr_heap, { cs & cs_symbol_table = cs_symbol_table })
......@@ -1456,7 +1456,7 @@ where
| entry.ste_kind =: STE_Empty
= symbol_table
= symbol_table <:= (id_info, entry.ste_previous)
checkDynamicTypes mod_index dyn_type_ptrs (Yes {st_vars}) type_defs class_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
checkDynamicTypes mod_index dyn_type_ptrs (FunDefType {st_vars}) type_defs class_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
# (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table)
(type_defs, class_defs, modules, heaps, expr_heap, cs)
= checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs class_defs modules
......
......@@ -1128,8 +1128,8 @@ where
cfvog_accu = [cases_of_vars_for_function:cfvog_accu]
strictness_accu = [get_strictness_list fun_def:strictness_accu]
with
get_strictness_list {fun_type = Yes {st_args_strictness}}
= st_args_strictness
get_strictness_list {fun_type = FunDefType {st_args_strictness}}
= st_args_strictness
ai = { ai
& ai_cases_of_vars_for_function = []
......@@ -1299,7 +1299,7 @@ where
reanalyse_functions NoComponentMembers common_defs (fun_index, cfvog_accu, strictness_accu, ai)
= (cfvog_accu, strictness_accu, ai)
reanalyse_function (TransformedBody {tb_args,tb_rhs}) (Yes {st_args_strictness}) function_pointer_or_index fun_index ai
reanalyse_function (TransformedBody {tb_args,tb_rhs}) (FunDefType {st_args_strictness}) function_pointer_or_index fun_index ai
# nr_of_locals = count_locals tb_rhs 0
nr_of_args = length tb_args
......
......@@ -292,7 +292,7 @@ where
= member_type_and_types_equal instance_member_type instance_member_types icl_instance_members (icl_member_n+1) icl_functions comp_st
# ({fun_type},icl_functions) = icl_functions![cim_index]
# (Yes icl_instance_member_type) = fun_type
# (FunDefType icl_instance_member_type) = fun_type
# tc_state = { tc_type_vars = initial_hwn comp_st.comp_type_var_heap
, tc_attr_vars = initial_hwn comp_st.comp_attr_var_heap
......@@ -702,8 +702,9 @@ compareTwoFunctionTypes :: !{#FunType} !Int !*(!u:{#FunDef},!*TypesCorrespondSta
compareTwoFunctionTypes dcl_fun_types dclIndex (icl_functions, tc_state, error_admin)
# (fun_def=:{fun_type, fun_priority}, icl_functions) = icl_functions![dclIndex]
= case fun_type of
No -> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
Yes icl_symbol_type
NoFunDefType
-> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
FunDefType icl_symbol_type
# {ft_type=dcl_symbol_type, ft_priority,ft_ident} = dcl_fun_types.[dclIndex]
# tc_state = init_symbol_type_vars dcl_symbol_type icl_symbol_type tc_state
(corresponds, tc_state)
......
......@@ -112,8 +112,8 @@ where
, ci_case_level :: !CaseLevel
}
convertCasesInBody :: FunctionBody (Optional SymbolType) Int {#CommonDefs} *ConvertState -> (FunctionBody, *ConvertState)
convertCasesInBody (TransformedBody body) (Yes type) group_index common_defs cs
convertCasesInBody :: FunctionBody FunDefType Int {#CommonDefs} *ConvertState -> (FunctionBody, *ConvertState)
convertCasesInBody (TransformedBody body) (FunDefType type) group_index common_defs cs
# (body, cs) = convertRootCases
{ ci_bound_vars = exactZip body.tb_args type.st_args
, ci_group_index = group_index
......@@ -1299,7 +1299,7 @@ newFunctionWithType opt_id fun_bodies local_vars fun_type group_index (cs_next_f
, fun_arity = arity
, fun_priority = NoPrio
, fun_body = fun_bodies
, fun_type = Yes fun_type
, fun_type = FunDefType fun_type
, fun_pos = NoPos
, fun_kind = FK_Function cNameNotLocationDependent
, fun_lifted = 0
......@@ -1317,13 +1317,13 @@ where
!(!*{!Component}, ![FunDef], !*{#{#CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
-> (!*{!Component}, ![FunDef], !*{#{#CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
add_new_function_to_group common_defs (fun_def,fun_index) (groups, fun_defs, imported_types, imported_conses, type_heaps, var_heap)
# {fun_type = Yes ft, fun_info = {fi_group_index, fi_properties}} = fun_def
# {fun_type = FunDefType ft, fun_info = {fi_group_index, fi_properties}} = fun_def
(ft, imported_types, imported_conses, type_heaps, var_heap)
= convertSymbolType (fi_properties bitand FI_HasTypeSpec == 0) common_defs ft main_dcl_module_n
imported_types imported_conses type_heaps var_heap
(group, groups) = groups![fi_group_index]
groups & [fi_group_index] = {group & component_members = ComponentMember fun_index group.component_members}
= (groups,[{fun_def & fun_type = Yes ft}: fun_defs], imported_types, imported_conses, type_heaps, var_heap)
= (groups,[{fun_def & fun_type = FunDefType ft}: fun_defs], imported_types, imported_conses, type_heaps, var_heap)
:: ConvertState =
{ cs_new_functions :: ![(FunDef,Index)]
......
......@@ -796,7 +796,13 @@ instance check_completeness FunctionBody where
= check_completeness body cci ccs
check_completeness (RhsMacroBody body) cci ccs
= check_completeness body cci ccs
instance check_completeness FunDefType where
check_completeness (FunDefType x) cci ccs
= check_completeness x cci ccs
check_completeness NoFunDefType _ ccs
= ccs
instance check_completeness FunDef where
check_completeness {fun_type, fun_body, fun_info} cci ccs
= ( (check_completeness fun_type cci)
......
......@@ -382,6 +382,10 @@ showGroups comps comp_index show_types fun_defs file
# (fun_defs, file) = show_group comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
= showGroups comps (inc comp_index) show_types fun_defs file
instance <<< FunDefType where
(<<<) file (FunDefType fun_def_type) = file <<< fun_def_type
(<<<) file NoFunDefType = file
show_group [] show_types fun_defs file
= (fun_defs, file <<< '\n')
show_group [fun:funs] show_types fun_defs file
......@@ -430,7 +434,7 @@ where
show_types [fun:funs] fun_defs file
# (fun_def, fun_defs) = fun_defs![fun]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No }
(Yes ftype) = fun_def.fun_type
(FunDefType ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_ident <<< " :: " <:: (properties, ftype, No) <<< '\n' )
showDclModules :: !u:{#DclModule} !*File -> (!u:{#DclModule}, !*File)
......
......@@ -1034,7 +1034,7 @@ where
build_cons_desc_list_function group_index {ds_ident} cons_info_dss heaps
# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
# (gtd_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps // gtd_conses
# fun = makeFunction ds_ident group_index [] gtd_conses_expr No main_module_index td_pos
# fun = makeFunction ds_ident group_index [] gtd_conses_expr NoFunDefType main_module_index td_pos
= (fun, heaps)
build_type_def_dsc group_index /*cons_info_dss*/ {ds_ident} cons_desc_list_ds heaps
......@@ -1045,7 +1045,7 @@ where
# (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor
[td_name_expr, td_arity_expr, num_conses_expr, gtd_conses_expr] // TODO: module_name_expr
predefs heaps
# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
# fun = makeFunction ds_ident group_index [] body_expr NoFunDefType main_module_index td_pos
= (fun, heaps)
build_cons_dsc group_index type_def_info_ds {ds_ident} gen_type_ds cons_ds (modules, heaps)
......@@ -1061,7 +1061,7 @@ where
= buildPredefConsApp PD_CGenericConsDescriptor
[name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr]
predefs heaps
# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
# fun = makeFunction ds_ident group_index [] body_expr NoFunDefType main_module_index td_pos
= (fun, (modules, heaps))
make_prio_expr NoPrio predefs heaps
......@@ -1116,7 +1116,7 @@ where
build_field_list_function group_index field_list_ds (modules, heaps)
# field_exprs = [makeStringExpr id_name \\ {fs_ident={id_name}}<-fields]
# (fields_expr, heaps) = makeListExpr field_exprs predefs heaps // grd_fields
# fun = makeFunction field_list_ds.ds_ident group_index [] fields_expr No main_module_index td_pos
# fun = makeFunction field_list_ds.ds_ident group_index [] fields_expr NoFunDefType main_module_index td_pos
= (fun, (modules, heaps))
build_record_dsc group_index td_ident cons_info_ds gen_type_ds field_list_ds cons_ds (modules, heaps)
......@@ -1131,7 +1131,7 @@ where
= buildPredefConsApp PD_CGenericRecordDescriptor
[name_expr, arity_expr, td_arity_expr, type_expr, fields_expr]
predefs heaps
# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos
# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr NoFunDefType main_module_index td_pos
= (fun, (modules, heaps))
build_field_dsc group_index record_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
......@@ -1144,7 +1144,7 @@ where
= buildPredefConsApp PD_CGenericFieldDescriptor
[name_expr, index_expr, cons_expr]
predefs heaps
# fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos
# fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr NoFunDefType main_module_index td_pos
= (fun, (modules, heaps))
build_gen_type_function :: !Index !Index !Index Position PredefinedSymbolsData !DefinedSymbol !DefinedSymbol !(!*Modules,!*Heaps)
......@@ -1152,7 +1152,7 @@ build_gen_type_function :: !Index !Index !Index Position PredefinedSymbolsData !
build_gen_type_function group_index main_module_index td_module td_pos predefs cons_info_ds cons_ds (modules, heaps)
# ({cons_type,cons_exi_vars}, modules) = modules![td_module].com_cons_defs.[cons_ds.ds_index]
# (type_expr, modules, heaps) = make_type_expr cons_exi_vars cons_type modules heaps
# fun = makeFunction cons_info_ds.ds_ident group_index [] type_expr No main_module_index td_pos
# fun = makeFunction cons_info_ds.ds_ident group_index [] type_expr NoFunDefType main_module_index td_pos
= (fun, (modules, heaps))
where
make_type_expr [] {st_vars, st_args, st_result} modules heaps=:{hp_type_heaps=type_heaps=:{th_vars}}
......@@ -1314,10 +1314,10 @@ buildConversionTo
# fun_name = makeIdent ("toGeneric" +++ td_ident.id_name)
| not error.ea_ok
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
= (buildFunAndGroup fun_name [] EE NoFunDefType main_module_index td_pos funs_and_groups)
= (def_sym, funs_and_groups, heaps, error)
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
= (buildFunAndGroup fun_name [arg_var] body_expr NoFunDefType main_module_index td_pos funs_and_groups)
= (def_sym, funs_and_groups, heaps, error)
where
// build conversion for type rhs
......@@ -1475,9 +1475,9 @@ buildConversionFrom type_def_mod type_def=:{td_rhs, td_ident, td_pos} main_modul
# (body_expr, arg_var, heaps, error) = build_expr_for_type_rhs type_def_mod td_rhs heaps error
# fun_name = makeIdent ("fromGeneric" +++ td_ident.id_name)
| not error.ea_ok
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [] EE NoFunDefType main_module_index td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups
# (def_sym, funs_and_groups) = buildFunAndGroup fun_name [arg_var] body_expr NoFunDefType main_module_index td_pos funs_and_groups
= (def_sym, funs_and_groups, heaps, error)
where
// build expression for type def rhs
......@@ -2897,7 +2897,7 @@ where
#! (st, heaps) = fresh_symbol_type st heaps
#! (fun_ds, fun_info)
= buildFunAndGroup fun_name arg_vars body_expr (Yes st) gs_main_module gc_pos fun_info
= buildFunAndGroup fun_name arg_vars body_expr (FunDefType st) gs_main_module gc_pos fun_info
= (fun_ds, fun_info, heaps)
where
......@@ -2981,7 +2981,7 @@ where
_
-> (tb_args,fun_arity)
# fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}
# fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity}
# fun & fun_ident = fun_ident, fun_type = FunDefType symbol_type, fun_body = fun_body, fun_arity = fun_arity
-> {st & ss_funs.[fun_index] = fun}
| generic_info<0
// keep generic info argument
......@@ -2998,7 +2998,7 @@ where
-> (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs},fun_arity)
_
-> (fun_body,fun_arity)
# fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity}
# fun & fun_ident = fun_ident, fun_type = FunDefType symbol_type, fun_body = fun_body, fun_arity = fun_arity
-> {st & ss_funs.[fun_index] = fun}
// generic info record already replaced by fields
# n_generic_info_field = add_n_bits generic_info 0
......@@ -3015,7 +3015,7 @@ where
-> (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs},fun_arity)
_
-> (fun_body,fun_arity)
# fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity}
# fun & fun_ident = fun_ident, fun_type = FunDefType symbol_type, fun_body = fun_body, fun_arity = fun_arity
-> {st & ss_funs.[fun_index] = fun}
// not a special generic instance, remove generic info argument
# tb_args = tl tb_args
......@@ -3025,7 +3025,7 @@ where
# error = reportError gc_ident.id_name gc_pos
("incorrect arity "+++toString fun_arity+++", expected "+++toString symbol_type.st_arity) st.ss_error
-> {st & ss_error=error}
# fun = {fun & fun_ident = fun_ident, fun_body = fun_body, fun_type = Yes symbol_type, fun_arity=fun_arity}
# fun & fun_ident = fun_ident, fun_body = fun_body, fun_type = FunDefType symbol_type, fun_arity=fun_arity
-> {st & ss_funs.[fun_index] = fun}
_ // derived case
| fun_body=:GeneratedBody || fun_body=:GenerateGenericBody _
......@@ -3036,7 +3036,7 @@ where
+++toString (length tb_args)+++",>32)"
-> {st & ss_error = reportError gc_ident.id_name gc_pos error_s st.ss_error}
# funs_and_groups=:{fg_group_index,fg_groups} = st.ss_funs_and_groups
#! fun = makeFunction fun_ident fg_group_index tb_args tb_rhs (Yes symbol_type) gs_main_module gc_pos
#! fun = makeFunction fun_ident fg_group_index tb_args tb_rhs (FunDefType symbol_type) gs_main_module gc_pos
# group = {group_members=[fun_index]}
funs_and_groups & fg_group_index=fg_group_index+1,fg_groups=[group:fg_groups]
-> {st & ss_funs.[fun_index] = fun, ss_funs_and_groups = funs_and_groups}
......@@ -3723,10 +3723,10 @@ where
where
convert_function :: !FunDef !(!*Modules, !*Heaps, !*ErrorAdmin)
-> (!FunDef,!(!*Modules, !*Heaps, !*ErrorAdmin))
convert_function fun=:{fun_type=Yes symbol_type, fun_ident, fun_pos} st
convert_function fun=:{fun_type=FunDefType symbol_type, fun_ident, fun_pos} st
# (has_converted_context, symbol_type, st) = convert_contexts_in_symbol_type fun_ident fun_pos symbol_type st
| has_converted_context
# fun = {fun & fun_type = Yes symbol_type}
# fun & fun_type = FunDefType symbol_type
= (fun, st)
= (fun, st)
convert_function fun st
......@@ -4191,7 +4191,7 @@ where
= if (generic_info<>0)
(add_generic_info_to_type fun_type gen_cons_index generic_info predefs)
fun_type
fun_def & fun_type = Yes fun_type_with_generic_info
fun_def & fun_type = FunDefType fun_type_with_generic_info
-> (fun_def,heaps)
No
-> (fun_def,heaps)
......@@ -4712,7 +4712,7 @@ where
add_bimap_to_simple_type_function case_expr arg_var bi_bimap_exprs old_bimap_exprs bs=:{bs_heaps}
# (bimap_exprs,bimap_args,heaps) = get_used_bimap_exprs bi_bimap_exprs old_bimap_exprs bs_heaps
# (def_sym, funs_and_groups)
= buildFunAndGroup (makeIdent "bimapToGeneric") (bimap_args++[arg_var]) case_expr No bi_main_module_index NoPos bs.bs_funs_and_groups
= buildFunAndGroup (makeIdent "bimapToGeneric") (bimap_args++[arg_var]) case_expr NoFunDefType bi_main_module_index NoPos bs.bs_funs_and_groups
# (app_expr, heaps) = buildFunApp bi_main_module_index def_sym (bimap_exprs++args) heaps
= (app_expr,{bs & bs_funs_and_groups=funs_and_groups,bs_heaps=heaps})
......@@ -4778,7 +4778,7 @@ where
add_bimap_from_simple_type_function case_expr arg_var bi_bimap_exprs old_bimap_exprs bs=:{bs_heaps}
# (bimap_exprs,bimap_args,heaps) = get_used_bimap_exprs bi_bimap_exprs old_bimap_exprs bs_heaps
# (def_sym, funs_and_groups)
= buildFunAndGroup (makeIdent "bimapFromGeneric") (bimap_args++[arg_var]) case_expr No bi_main_module_index NoPos bs.bs_funs_and_groups
= buildFunAndGroup (makeIdent "bimapFromGeneric") (bimap_args++[arg_var]) case_expr NoFunDefType bi_main_module_index NoPos bs.bs_funs_and_groups
# (app_expr, heaps) = buildFunApp bi_main_module_index def_sym (bimap_exprs++args) heaps