Commit 92cd91f5 authored by John van Groningen's avatar John van Groningen

refactor, improve code using new macros for predefined type indices

parent 8dd0461f
......@@ -1207,10 +1207,10 @@ predefineSymbols {dcl_common} predefs
define_unit_type
# constructor_symbol_be_f = BEConstructorSymbol predefs.[PD_UnitConsSymbol].pds_def cPredefinedModuleIndex
constructors_be_f = @^^^ BEConstructorList constructor_symbol_be_f BENoTypeArgs BENoConstructors
type_symbol_be_f = BETypeSymbol predefs.[PD_UnitType].pds_def cPredefinedModuleIndex
type_symbol_be_f = BETypeSymbol PD_UnitTypeIndex cPredefinedModuleIndex
= appBackEnd
( BEDeclareConstructor predefs.[PD_UnitConsSymbol].pds_def cPredefinedModuleIndex "_Unit"
o` BEDeclareType predefs.[PD_UnitType].pds_def cPredefinedModuleIndex "_Unit"
o` BEDeclareType PD_UnitTypeIndex cPredefinedModuleIndex "_Unit"
o` @^&^ BEDefineAlgebraicType type_symbol_be_f BENoUniAttr constructors_be_f)
bindSpecialIdents :: PredefinedSymbols NumberSet -> BackEnder
......
......@@ -11,8 +11,8 @@ checkFunctions :: !Index !Level !Index !Index !Int !*{#FunDef} !*ExpressionInfo
checkDclMacros :: !Index !Level !Index !Index !*ExpressionInfo !*Heaps !*CheckState
-> (!*ExpressionInfo,!*Heaps,!*CheckState)
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !p:PredefinedSymbols !*{#FunDef}
-> (!*ErrorAdmin,!p:PredefinedSymbols,!*{#FunDef})
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !*{#FunDef}
-> (!*ErrorAdmin,!*{#FunDef})
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
......
......@@ -885,13 +885,13 @@ where
= case tc_types of
[TA {type_index} [],TV _]
# {pds_def,pds_module} = predef_symbols.[PD_ArrayClass]
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_array type_index predef_symbols
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_array type_index
-> (tc_types, predef_symbols,error)
# {pds_def,pds_module} = predef_symbols.[PD_ListClass]
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_list type_index predef_symbols
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_list type_index
-> (tc_types, predef_symbols,error)
# {pds_module,pds_def} = predef_symbols.[PD_MaybeClass]
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_maybe type_index predef_symbols
| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_maybe type_index
-> (tc_types, predef_symbols,error)
_
-> (tc_types, predef_symbols,checkError ds_ident.id_name "illegal specialization" error)
......@@ -905,38 +905,18 @@ where
hasNoTypeVariables [ _ : types]
= hasNoTypeVariables types
is_lazy_or_strict_array {glob_module,glob_object} predef_symbols
# {pds_def,pds_module} = predef_symbols.[PD_LazyArrayType]
| glob_module==pds_module && glob_object==pds_def
= True
# {pds_def,pds_module} = predef_symbols.[PD_StrictArrayType]
| glob_module==pds_module && glob_object==pds_def
= True
= False
is_lazy_or_strict_array {glob_module,glob_object}
= glob_module==cPredefinedModuleIndex &&
(glob_object==PD_LazyArrayTypeIndex || glob_object==PD_StrictArrayTypeIndex)
is_lazy_or_strict_list {glob_module,glob_object} predef_symbols
# {pds_def,pds_module} = predef_symbols.[PD_ListType]
| glob_module==pds_module && glob_object==pds_def
= True
# {pds_def,pds_module} = predef_symbols.[PD_StrictListType]
| glob_module==pds_module && glob_object==pds_def
= True
# {pds_def,pds_module} = predef_symbols.[PD_TailStrictListType]
| glob_module==pds_module && glob_object==pds_def
= True
# {pds_def,pds_module} = predef_symbols.[PD_StrictTailStrictListType]
| glob_module==pds_module && glob_object==pds_def
= True
= False
is_lazy_or_strict_list {glob_module,glob_object}
= glob_module==cPredefinedModuleIndex &&
(glob_object==PD_ListTypeIndex || glob_object==PD_StrictListTypeIndex ||
glob_object==PD_TailStrictListTypeIndex || glob_object==PD_StrictTailStrictListTypeIndex)
is_lazy_or_strict_maybe {glob_module,glob_object} predef_symbols
# {pds_def,pds_module} = predef_symbols.[PD_MaybeType]
| glob_module==pds_module && glob_object==pds_def
= True
# {pds_def,pds_module} = predef_symbols.[PD_StrictMaybeType]
| glob_module==pds_module && glob_object==pds_def
= True
= False
is_lazy_or_strict_maybe {glob_module,glob_object}
= glob_module==cPredefinedModuleIndex &&
(glob_object==PD_MaybeTypeIndex || glob_object==PD_StrictMaybeTypeIndex)
initializeContextVariables :: ![TypeContext] !*VarHeap -> (![TypeContext], !*VarHeap)
initializeContextVariables contexts var_heap
......@@ -2773,13 +2753,12 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
= (False, abort "evaluated error 2 (check.icl)", {}, {}, {}, cs.cs_x.x_main_dcl_module_n,heaps, cs.cs_predef_symbols, cs.cs_symbol_table, cs.cs_error.ea_file, [])
# cs_symbol_table = cs.cs_symbol_table
cs_predef_symbols = cs.cs_predef_symbols
hp_var_heap = heaps.hp_var_heap
# (dcl_modules,cs_predef_symbols,hp_var_heap,cs_symbol_table)
# (dcl_modules,hp_var_heap,cs_symbol_table)
= if support_dynamics
(addDclTypeFunctions nr_of_cached_modules dcl_modules cs_predef_symbols hp_var_heap cs_symbol_table)
(dcl_modules,cs_predef_symbols,hp_var_heap,cs_symbol_table)
# cs = {cs & cs_symbol_table = cs_symbol_table, cs_predef_symbols = cs_predef_symbols}
(addDclTypeFunctions nr_of_cached_modules dcl_modules hp_var_heap cs_symbol_table)
(dcl_modules,hp_var_heap,cs_symbol_table)
# cs & cs_symbol_table = cs_symbol_table
heaps = {heaps & hp_var_heap=hp_var_heap}
# (icl_common,local_defs,dcl_modules)
......@@ -2843,15 +2822,15 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
#! n_class_defs = dcl_sizes.[cClassDefs]
-> (n_dcl_type_defs,n_class_defs)
# {cs_symbol_table,cs_predef_symbols} = cs
# {cs_symbol_table} = cs
{com_type_defs,com_class_defs} = icl_common
hp_var_heap = heaps.hp_var_heap
(icl_type_fun_range,icl_functions,com_type_defs,com_class_defs,cs_predef_symbols,hp_var_heap,cs_symbol_table)
(icl_type_fun_range,icl_functions,com_type_defs,com_class_defs,hp_var_heap,cs_symbol_table)
= if support_dynamics
(addIclTypeFunctions n_dcl_type_defs n_dcl_class_defs icl_functions com_type_defs com_class_defs cs_predef_symbols hp_var_heap cs_symbol_table)
({ir_from=0,ir_to=0},icl_functions,com_type_defs,com_class_defs,cs_predef_symbols,hp_var_heap,cs_symbol_table)
(addIclTypeFunctions n_dcl_type_defs n_dcl_class_defs icl_functions com_type_defs com_class_defs hp_var_heap cs_symbol_table)
({ir_from=0,ir_to=0},icl_functions,com_type_defs,com_class_defs,hp_var_heap,cs_symbol_table)
icl_common = {icl_common & com_type_defs=com_type_defs,com_class_defs=com_class_defs}
cs = {cs & cs_symbol_table=cs_symbol_table, cs_predef_symbols=cs_predef_symbols}
cs & cs_symbol_table=cs_symbol_table
heaps = {heaps & hp_var_heap=hp_var_heap}
# (nr_of_functions, icl_functions) = usize icl_functions
......@@ -3177,16 +3156,16 @@ checkForeignExports [{pfe_ident=pfe_ident=:{id_name,id_info},pfe_line,pfe_file,p
checkForeignExports [] icl_global_functions_ranges fun_defs cs
= ([],fun_defs,cs)
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !p:PredefinedSymbols !*{#FunDef}
-> (!*ErrorAdmin,!p:PredefinedSymbols,!*{#FunDef})
checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admin predefined_symbols fun_defs
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !*{#FunDef}
-> (!*ErrorAdmin,!*{#FunDef})
checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admin fun_defs
| not (check_foreign_export_type st_result.at_type)
# error_admin = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in result type for foreign exported function" error_admin
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin predefined_symbols fun_defs2
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
| not (check_foreign_export_types st_args)
# error_admin = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in argument type for foreign exported function" error_admin
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin predefined_symbols fun_defs2
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin predefined_symbols fun_defs2
= 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]
......@@ -3202,8 +3181,7 @@ checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admi
check_foreign_export_type (TB (BT_String _))
= True
check_foreign_export_type (TA {type_index={glob_module,glob_object},type_arity} [{at_type=TB basic_type}])
| predefined_symbols.[PD_UnboxedArrayType].pds_def==glob_object &&
predefined_symbols.[PD_UnboxedArrayType].pds_module==glob_module
| glob_module==cPredefinedModuleIndex && glob_object==PD_UnboxedArrayTypeIndex
= case basic_type of
BT_Char -> True
BT_Int -> True
......@@ -3215,8 +3193,8 @@ checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admi
&& first_n_are_strict type_arity strictness && check_foreign_export_types arguments
check_foreign_export_type _
= False
checkForeignExportedFunctionTypes [] error_admin predefined_symbols fun_defs
= (error_admin,predefined_symbols,fun_defs)
checkForeignExportedFunctionTypes [] error_admin fun_defs
= (error_admin,fun_defs)
check_dynamics_used_without_support_dynamics support_dynamics mod_ident cs
| not support_dynamics && (cs.cs_x.x_needed_modules bitand cNeedStdDynamic)<>0
......@@ -3573,8 +3551,7 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
| mod_index == cs_predef_symbols.[PD_StdArray].pds_def
#! nr_of_instances = size class_instances
# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
(class_instances, cs_predef_symbols)
= iFoldSt (adjust_instances_of_array_functions mod_index pds_def) 0 nr_of_instances (class_instances, cs_predef_symbols)
class_instances = iFoldSt (adjust_instances_of_array_functions mod_index pds_def) 0 nr_of_instances class_instances
= (class_instances, {cs & cs_predef_symbols = cs_predef_symbols})
| mod_index == cs_predef_symbols.[PD_StdStrictLists].pds_def
#! n_of_instances = size class_instances
......@@ -3588,19 +3565,16 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
= (class_instances, {cs & cs_predef_symbols = cs_predef_symbols})
= (class_instances, cs)
where
adjust_instances_of_array_functions :: Index !Index !Int !*(!*{#ClassInstance},!v:{#PredefinedSymbol})
-> (!*{#ClassInstance},!v:{#PredefinedSymbol})
adjust_instances_of_array_functions array_mod_index array_class_index inst_index (class_instances, predef_symbols)
adjust_instances_of_array_functions :: Index !Index !Int !*{#ClassInstance} -> *{#ClassInstance}
adjust_instances_of_array_functions array_mod_index array_class_index inst_index class_instances
# ({ins_class_index={gi_module,gi_index},ins_type}, class_instances) = class_instances![inst_index]
| gi_module==array_mod_index && gi_index==array_class_index && is_polymorphic_unboxed_or_packed_array_instance_type ins_type.it_types predef_symbols
# class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances
= (class_instances, predef_symbols)
= (class_instances, predef_symbols)
| gi_module==array_mod_index && gi_index==array_class_index && is_polymorphic_unboxed_or_packed_array_instance_type ins_type.it_types
= {class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances}
= class_instances
is_polymorphic_unboxed_or_packed_array_instance_type [TA {type_index={glob_object,glob_module}} _, TV _ : _] predef_symbols
= glob_module == predef_symbols.[PD_PredefinedModule].pds_def &&
(glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def || glob_object == predef_symbols.[PD_PackedArrayType].pds_def)
is_polymorphic_unboxed_or_packed_array_instance_type _ _
is_polymorphic_unboxed_or_packed_array_instance_type [TA {type_index={glob_object,glob_module}} _, TV _ : _]
= glob_module == cPredefinedModuleIndex && (glob_object == PD_UnboxedArrayTypeIndex || glob_object == PD_PackedArrayTypeIndex)
is_polymorphic_unboxed_or_packed_array_instance_type _
= False
adjust_instances_of__SystemStrictLists_module :: !Index !Int !*(!*{#ClassInstance},!v:{#PredefinedSymbol})
......
......@@ -313,7 +313,7 @@ where
case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
NoPos, var_store, expr_heap, opt_dynamics, cs)
transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
# (basic_type, cs) = typeOfBasicValue basic_val cs
# basic_type = typeOfBasicValue basic_val
(act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }]
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
......@@ -1220,7 +1220,7 @@ transform_pattern (AP_Algebraic cons_symbol global_type_index args opt_var) patt
transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs
# pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = pos}
pattern_variables = cons_optional opt_var pattern_variables
(type_symbol, cs) = typeOfBasicValue basic_val cs
type_symbol = typeOfBasicValue basic_val
= case pattern_scheme of
BasicPatterns basic_type _
| type_symbol == basic_type
......@@ -2183,7 +2183,7 @@ convertSubPattern (AP_Algebraic cons_symbol global_type_index args opt_var) resu
case_default_pos = NoPos },
NoPos, var_store, expr_heap, opt_dynamics, cs)
convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs
# (basic_type, cs) = typeOfBasicValue basic_val cs
# basic_type = typeOfBasicValue basic_val
case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }]
({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
(var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
......@@ -2958,15 +2958,13 @@ where
_
-> ({ ds_ident = symb_id, ds_index = NoIndex, ds_arity = arity }, { cs & cs_error = checkError symb_id "undefined" cs.cs_error })
typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState)
typeOfBasicValue (BVI _) cs = (BT_Int, cs)
typeOfBasicValue (BVInt _) cs = (BT_Int, cs)
typeOfBasicValue (BVC _) cs = (BT_Char, cs)
typeOfBasicValue (BVB _) cs = (BT_Bool, cs)
typeOfBasicValue (BVR _) cs = (BT_Real, cs)
typeOfBasicValue (BVS _) cs
# ({glob_module,glob_object={ds_ident,ds_index,ds_arity}}, cs) = getPredefinedGlobalSymbol PD_StringType PD_PredefinedModule STE_Type 0 cs
= (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), cs)
typeOfBasicValue :: !BasicValue -> BasicType
typeOfBasicValue (BVI _) = BT_Int
typeOfBasicValue (BVInt _) = BT_Int
typeOfBasicValue (BVC _) = BT_Char
typeOfBasicValue (BVB _) = BT_Bool
typeOfBasicValue (BVR _) = BT_Real
typeOfBasicValue (BVS _) = BT_String (TA (MakeTypeSymbIdent { glob_object = PD_StringTypeIndex, glob_module = cPredefinedModuleIndex } predefined_idents.[PD_StringType] 0) [])
buildTypeCase type_case_dynamic type_case_patterns type_case_default type_case_info_ptr case_explicit :==
Case { case_expr = type_case_dynamic, case_guards = DynamicPatterns type_case_patterns, case_default = type_case_default,
......
......@@ -206,8 +206,8 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
# {dcl_instances,dcl_specials,dcl_gencases,dcl_type_funs} = dcl_mods.[main_dcl_module_n]
# (start_function_index,predef_symbols) = get_index_of_start_rule main_dcl_module_n predef_symbols
# (error_admin,predef_symbols,fun_defs)
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin predef_symbols fun_defs
# (error_admin,fun_defs)
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs
# [icl_exported_global_functions,icl_not_exported_global_functions:_] = icl_global_functions
# exported_global_functions = case start_function_index of
......
......@@ -450,13 +450,13 @@ buildGenericTypeRep type_index funs_and_groups
buildBimapGenericTypeRep :: !GlobalIndex !*GenericState -> (!BimapGenTypeStruct,!*GenericState)
buildBimapGenericTypeRep type_index
gs=:{gs_modules, gs_predefs, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
gs=:{gs_modules, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]
// remove TVI_TypeKind's, otherwise: abort "type var is not empty", buildTypeDefInfo seems to do this in buildGenericTypeRep
gs_tvarh = remove_type_argument_numbers type_def.td_args gs_tvarh
heaps = {hp_expression_heap=gs_exprh, hp_var_heap=gs_varh, hp_generic_heap=gs_genh, hp_type_heaps={th_vars=gs_tvarh, th_attrs=gs_avarh}}
(atype, (gs_modules, gs_td_infos, heaps, gs_error))
= buildBimapStructType type_index gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
= buildBimapStructType type_index (gs_modules, gs_td_infos, heaps, gs_error)
{hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos, gs_error = gs_error, gs_avarh = th_attrs,
gs_tvarh = th_vars, gs_varh = hp_var_heap, gs_genh = hp_generic_heap, gs_exprh = hp_expression_heap
......@@ -464,9 +464,9 @@ buildBimapGenericTypeRep type_index
// the structure type
convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos {psd_predefs_a} type st
convertATypeToGenTypeStruct :: !Ident !Position !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos type st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
......@@ -496,8 +496,7 @@ where
-> convert {at_type = expanded_type, at_attribute = attr}
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
_
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
| type_index.glob_module == cPredefinedModuleIndex && type_index.glob_object == PD_UnboxedArrayTypeIndex
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
| otherwise
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
......@@ -505,9 +504,9 @@ where
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
-> (GTSAppCons kind args, st)
convertATypeToBimapGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToBimapGenTypeStruct ident pos {psd_predefs_a} type st
convertATypeToBimapGenTypeStruct :: !Ident !Position !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToBimapGenTypeStruct ident pos type st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
......@@ -537,8 +536,7 @@ where
-> convert {at_type = expanded_type, at_attribute = attr}
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
AbstractType _
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module && type_index.glob_object == pds_def
| type_index.glob_module == cPredefinedModuleIndex && type_index.glob_object == PD_UnboxedArrayTypeIndex
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
AlgType alts
# n_args = length args
......@@ -559,9 +557,9 @@ where
#! (args, st) = mapSt convert args (modules, td_infos, heaps, error)
= (BGTSAppCons kind args, st)
convert_generic_function_type_to_BimapGenTypeStruct :: !AType !Position !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_generic_function_type_to_BimapGenTypeStruct type pos {psd_predefs_a} st
convert_generic_function_type_to_BimapGenTypeStruct :: !AType !Position (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (BimapGenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_generic_function_type_to_BimapGenTypeStruct type pos st
= convert type st
where
convert {at_type=TA type_symb args, at_attribute} st
......@@ -591,8 +589,7 @@ where
-> convert {at_type = expanded_type, at_attribute = attr}
(modules, td_infos, {heaps & hp_type_heaps = th}, error)
AbstractType _
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| glob_module == pds_module && glob_object == pds_def
| glob_module == cPredefinedModuleIndex && glob_object == PD_UnboxedArrayTypeIndex
-> (BGTSAppCons KindConst [], (modules, td_infos, heaps, error))
AlgType alts
# n_args = length args
......@@ -863,17 +860,17 @@ where
(modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos) st_args (modules, td_infos, heaps, error)
# args = [GTSField fi {gi_module=gi_module,gi_index=fs_index} ci_record_info arg \\ arg <- args & fi <- ci_field_infos & {fs_index}<-:rt_fields]
# prod_type = build_prod_type args
= (GTSRecord ci_record_info {gi_module=gi_module,gi_index=gi_index} gen_type_ds field_list_ds prod_type, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
build_type {td_rhs=NewType cons, td_ident, td_pos} (AlgebraicInfo type_info cons_desc_list_ds _ _) st
# (type, st) = build_newtype_alt td_ident td_pos cons gi_module predefs st
# (type, st) = build_newtype_alt td_ident td_pos cons gi_module st
= (GTSObject type_info {gi_module=gi_module,gi_index=gi_index} cons_desc_list_ds type, st)
build_type {td_rhs=AbstractNewType _ cons, td_ident, td_pos} (AlgebraicInfo type_info cons_desc_list_ds _ _) st
# (type, st) = build_newtype_alt td_ident td_pos cons gi_module predefs st
# (type, st) = build_newtype_alt td_ident td_pos cons gi_module st
= (GTSObject type_info {gi_module=gi_module,gi_index=gi_index} cons_desc_list_ds type, st)
build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of a synonym type" error
......@@ -885,28 +882,27 @@ where
build_alt td_ident td_pos type_info cons_def_sym=:{ds_index} cons_info gen_type_ds (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos) st_args (modules, td_infos, heaps, error)
# prod_type = build_prod_type args
= (GTSCons cons_info {gi_module=gi_module,gi_index=ds_index} type_info gen_type_ds prod_type, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module predefs (modules, td_infos, heaps, error)
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# st_arg = case st_args of [st_arg] -> st_arg;
= convertATypeToGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)
= convertATypeToGenTypeStruct td_ident td_pos st_arg (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
buildBimapStructType ::
!GlobalIndex // type def global index
!PredefinedSymbolsData
(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> ( !BimapGenTypeStruct // the structure type
, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
)
buildBimapStructType {gi_module,gi_index} predefs (modules, td_infos, heaps, error)
buildBimapStructType {gi_module,gi_index} (modules, td_infos, heaps, error)
# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]
= build_type type_def (modules, td_infos, heaps, error)
where
......@@ -916,12 +912,12 @@ where
build_type {td_rhs=RecordType {rt_constructor,rt_fields}, td_ident, td_pos} (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos) st_args (modules, td_infos, heaps, error)
= (BGTSRecord args, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (BGTSE, (modules, td_infos, heaps, error))
build_type {td_rhs=NewType cons, td_ident, td_pos} st
= build_newtype_alt td_ident td_pos cons gi_module predefs st
= build_newtype_alt td_ident td_pos cons gi_module st
build_type {td_rhs=SynType type,td_ident, td_pos} (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of a synonym type" error
= (BGTSE, (modules, td_infos, heaps, error))
......@@ -932,16 +928,16 @@ where
build_alt td_ident td_pos cons_def_sym=:{ds_index} (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| cons_exi_vars=:[]
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# (args, st) = mapSt (convertATypeToBimapGenTypeStruct td_ident td_pos) st_args (modules, td_infos, heaps, error)
= (args, st)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= ([], (modules, td_infos, heaps, error))
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module predefs (modules, td_infos, heaps, error)
build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} gi_module (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# st_arg = case st_args of [st_arg] -> st_arg;
= convertATypeToBimapGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)
= convertATypeToBimapGenTypeStruct td_ident td_pos st_arg (modules, td_infos, heaps, error)
# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
= (BGTSE, (modules, td_infos, heaps, error))
......@@ -2844,7 +2840,7 @@ where
add_OBJECT_field_args generic_info args predefs=:{psd_predefs_a}
| generic_info bitand 1<>0 // gtd_name
# (args,n_args) = add_OBJECT_field_args (generic_info bitxor 1) args predefs
= add_String_arg args n_args psd_predefs_a
= add_String_arg args n_args
| generic_info bitand 2<>0 // gtd_arity
# (args,n_args) = add_OBJECT_field_args (generic_info bitxor 2) args predefs
= add_Int_arg args n_args
......@@ -2856,15 +2852,14 @@ where
# {pds_module, pds_def} = psd_predefs_a.[PD_TGenericConsDescriptor]
#! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericConsDescriptor] 0
# type_GenericConsDescriptor = {at_type= TA type_symb [], at_attribute = TA_Multi}
# {pds_module,pds_def} = psd_predefs_a.[PD_ListType]
#! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_ListType] 1
= ([{at_type = TA string_type_symb [type_GenericConsDescriptor], at_attribute = TA_Multi} : args],n_args+1)
#! list_type_symb = MakeTypeSymbIdent {glob_module = cPredefinedModuleIndex, glob_object = PD_ListTypeIndex} predefined_idents.[PD_ListType] 1
= ([{at_type = TA list_type_symb [type_GenericConsDescriptor], at_attribute = TA_Multi} : args],n_args+1)
= (args,0)
add_CONS_field_args generic_info args predefs=:{psd_predefs_a}
| generic_info bitand 1<>0 // gcd_name
# (args,n_args) = add_CONS_field_args (generic_info bitxor 1) args predefs
= add_String_arg args n_args psd_predefs_a
= add_String_arg args n_args
| generic_info bitand 2<>0 // gcd_arity
# (args,n_args) = add_CONS_field_args (generic_info bitxor 2) args predefs
= add_Int_arg args n_args
......@@ -2891,7 +2886,7 @@ where
add_RECORD_field_args generic_info args predefs=:{psd_predefs_a}
| generic_info bitand 1<>0 // grd_name
# (args,n_args) = add_RECORD_field_args (generic_info bitxor 1) args predefs
= add_String_arg args n_args psd_predefs_a
= add_String_arg args n_args
| generic_info bitand 2<>0 // grd_arity
# (args,n_args) = add_RECORD_field_args (generic_info bitxor 2) args predefs
= add_Int_arg args n_args
......@@ -2905,18 +2900,16 @@ where
= ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1)
| generic_info bitand 16<>0 // grd_fields
# (args,n_args) = add_RECORD_field_args (generic_info bitxor 16) args predefs
# {pds_module,pds_def} = psd_predefs_a.[PD_StringType]
#! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_StringType] 0
#! string_type_symb = MakeTypeSymbIdent {glob_module = cPredefinedModuleIndex, glob_object = PD_StringTypeIndex} predefined_idents.[PD_StringType] 0
# string_type = {at_type = TA string_type_symb [], at_attribute = TA_Multi}
# {pds_module,pds_def} = psd_predefs_a.[PD_ListType]
#! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_ListType] 1
= ([{at_type = TA string_type_symb [string_type], at_attribute = TA_Multi} : args],n_args+1)
#! list_type_symb = MakeTypeSymbIdent {glob_module = cPredefinedModuleIndex, glob_object = PD_ListTypeIndex} predefined_idents.[PD_ListType] 1
= ([{at_type = TA list_type_symb [string_type], at_attribute = TA_Multi} : args],n_args+1)
= (args,0)
add_FIELD_field_args generic_info args predefs=:{psd_predefs_a}
| generic_info bitand 1<>0 // gfd_name
# (args,n_args) = add_FIELD_field_args (generic_info bitxor 1) args predefs
= add_String_arg args n_args psd_predefs_a
= add_String_arg args n_args
| generic_info bitand 2<>0 // gfd_index
# (args,n_args) = add_FIELD_field_args (generic_info bitxor 2) args predefs
= add_Int_arg args n_args
......@@ -2927,9 +2920,8 @@ where
= ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1)
= (args,0)
add_String_arg args n_args psd_predefs_a
# {pds_module,pds_def} = psd_predefs_a.[PD_StringType]
#! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_StringType] 0
add_String_arg args n_args
#! string_type_symb = MakeTypeSymbIdent {glob_module = cPredefinedModuleIndex, glob_object = PD_StringTypeIndex} predefined_idents.[PD_StringType] 0
= ([{at_type = TA string_type_symb [], at_attribute = TA_Multi} : args],n_args+1)
add_Int_arg args n_args
......@@ -3173,7 +3165,7 @@ adapt_specialized_expr gc_pos {gen_type, gen_vars, gen_info_ptr} {gtr_to,gtr_fro
#! curried_gen_type = curry_symbol_type gen_type
#! (struct_gen_type, (modules, td_infos, heaps, error))
= convert_generic_function_type_to_BimapGenTypeStruct curried_gen_type gc_pos predefs (modules, td_infos, heaps, error)
= convert_generic_function_type_to_BimapGenTypeStruct curried_gen_type gc_pos (modules, td_infos, heaps, error)
#! (struct_gen_type, heaps) = simplify_bimap_GenTypeStruct gen_vars struct_gen_type heaps
......
This diff is collapsed.
......@@ -2739,9 +2739,8 @@ where
convert_array_instances array_instances common_defs fun_defs predef_symbols type_heaps error
| isEmpty array_instances
= ([],fun_defs, predef_symbols, type_heaps, error)
# ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_UnboxedArrayType]
# pds_ident = predefined_idents.[PD_UnboxedArrayType]
unboxed_array_type = TA (MakeTypeSymbIdent { glob_object = pds_def, glob_module = pds_module } pds_ident 0) []
unboxed_array_type = TA (MakeTypeSymbIdent { glob_object = PD_UnboxedArrayTypeIndex, glob_module = cPredefinedModuleIndex } pds_ident 0) []
({pds_module,pds_def},predef_symbols) = predef_symbols![PD_ArrayClass]
{class_members} = common_defs.[pds_module].com_class_defs.[pds_def]
array_members = common_defs.[pds_module].com_member_defs
......
......@@ -9,11 +9,11 @@ from syntax import
from predef import
::PredefinedSymbols, ::PredefinedSymbol
addDclTypeFunctions :: !Int !*{#DclModule} !*PredefinedSymbols !*VarHeap !*SymbolTable
-> (!*{#DclModule},!*PredefinedSymbols,!*VarHeap,!*SymbolTable)
addDclTypeFunctions :: !Int !*{#DclModule} !*VarHeap !*SymbolTable
-> (!*{#DclModule},!*VarHeap,!*SymbolTable)
addIclTypeFunctions :: !Int !Int !*{#FunDef} !*{#CheckedTypeDef} !*{#ClassDef} !*PredefinedSymbols !*VarHeap !*SymbolTable
-> (!IndexRange,!*{#FunDef},!*{#CheckedTypeDef},!*{#ClassDef},!*PredefinedSymbols,!*VarHeap,!*SymbolTable)
addIclTypeFunctions :: !Int !Int !*{#FunDef} !*{#CheckedTypeDef} !*{#ClassDef} !*VarHeap !*SymbolTable
-> (!IndexRange,!*{#FunDef},!*{#CheckedTypeDef},!*{#ClassDef},!*VarHeap,!*SymbolTable)
buildTypeFunctions :: !Int !*{#FunDef} !{#CommonDefs} !*PredefinedSymbols !*VarHeap !*TypeHeaps
-> (!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps)
......@@ -74,11 +74,9 @@ add_fun_types_of_dcl_module ctListDefSymb dcl_mod=:{dcl_functions, dcl_common={c
}
= (dcl_mod, var_heap, symbols)