Commit 62cb857f authored by clean's avatar clean
Browse files

Merge Martin/ Sjaak & Ronny branches

parent e783db98
......@@ -309,7 +309,8 @@ analTypeDef modules type_module type_index as=:{as_error,as_heaps,as_kind_heap,a
| is_abs_type
# (tdi, as_td_infos) = as_td_infos![type_module].[type_index]
tdi = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], tdi_group = [{glob_module = type_module, glob_object = type_index}],
tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = abs_type_properties }
tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = abs_type_properties,
tdi_tmp_index = 0 }
= (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, { as & as_td_infos = { as_td_infos & [type_module].[type_index] = tdi}}))
# position = newPosition td_name td_pos
as_error = pushErrorAdmin position as_error
......@@ -429,7 +430,7 @@ where
= (kind_store, kind_heap, { td_infos & [glob_module].[glob_object] =
{td_info & tdi_properties = type_properties, tdi_kinds = td_kinds, tdi_group = group,
tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr, tdi_tmp_index = loc_type_index } })
// ---> ("update_type_def_info", glob_module, glob_object, group_nr)
// ---> ("update_type_def_info", glob_module, glob_object, (group_nr, loc_type_index))
where
determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap
#! kind_info = sreadPtr kind_info_ptr kind_heap
......
......@@ -30,7 +30,7 @@ typeProperties type_index module_index hio_signs hio_props defs type_var_heap td
(tsp_propagation, type_var_heap, td_infos) = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos
tsp_coercible = (td_info.tdi_properties bitand cIsNonCoercible) == 0
= ({tsp_sign = tsp_sign, tsp_propagation = tsp_propagation, tsp_coercible = tsp_coercible }, type_var_heap, td_infos)
---> ("typeProperties", (td_name, type_index, module_index), tsp_sign, tsp_propagation)
// ---> ("typeProperties", (td_name, type_index, module_index), tsp_sign, tsp_propagation)
signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos
-> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos)
......@@ -72,6 +72,7 @@ determineSignClassOfTypeDef type_index module_index td_args {tdi_classification,
No
# signs_of_group_vars = foldSt (determine_signs_of_group_var tdi_cons_vars hio_signs) tdi_group_vars []
-> newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index}
// tdi_group (signs_of_group_vars ---> ("determine_signs_of_group_var", (module_index, type_index), signs_of_group_vars, tdi_group_vars)) ci type_var_heap td_infos
tdi_group signs_of_group_vars ci type_var_heap td_infos
where
......@@ -132,6 +133,7 @@ where
collect_sign_class_of_type_def group_nr signs_of_group_vars ci {glob_module,glob_object} (sign_requirements, type_var_heap, td_infos)
# ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object]
{td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, (glob_module, glob_object), tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
(rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap)
(sign_env, scs) = sign_class_of_type_def glob_module td_rhs group_nr ci
{scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] }
......@@ -177,6 +179,8 @@ where
| this_gv == gv
= sign
= retrieve_sign this_gv signs
retrieve_sign this_gv [ ]
= TopSignClass
restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap
# (TVI_SignClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
......@@ -426,10 +430,12 @@ where
= bind_type_vars_to_props tvs gvs tks props_of_group_vars ([prop:rev_hio_props], type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info))
= bind_type_vars_to_props tvs gvs tks props_of_group_vars (rev_hio_props, type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info))
where
retrieve_prop this_gv [(gv,prop) : signs ]
retrieve_prop this_gv [(gv,prop) : props ]
| this_gv == gv
= prop
= retrieve_prop this_gv signs
= retrieve_prop this_gv props
retrieve_prop this_gv [ ]
= PropClass
restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap
# (TVI_PropClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
......
......@@ -4,7 +4,7 @@ import syntax, transform, checksupport, typesupport, predef
cPredefinedModuleIndex :== 1
checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
checkModule :: !ScannedModule !IndexRange ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
-> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File)
retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index)
......
......@@ -7,6 +7,10 @@ import explicitimports, comparedefimp
cPredefinedModuleIndex :== 1
isMainModule :: ModuleKind -> Bool
isMainModule MK_Main = True
isMainModule _ = False
convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index
convertIndex index table_index (Yes tables)
= tables.[table_index].[index]
......@@ -2571,9 +2575,9 @@ where
(<=<) state fun :== fun state
checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
checkModule :: !ScannedModule !IndexRange ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
-> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File)
checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} nr_of_global_funs fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file
checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} icl_global_function_range fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file
# error = {ea_file = err_file, ea_loc = [], ea_ok = True }
first_inst_index = length fun_defs
......@@ -2584,7 +2588,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
#! nr_of_functions = size icl_functions
# sizes_and_local_defs = collectCommonfinitions cdefs
(icl_functions, sizes_and_local_defs) = collectGlobalFunctions cFunctionDefs 0 nr_of_global_funs icl_functions sizes_and_local_defs
(icl_functions, sizes_and_local_defs) = collectGlobalFunctions cFunctionDefs icl_global_function_range.ir_from icl_global_function_range.ir_to icl_functions sizes_and_local_defs
(icl_functions, (sizes, local_defs)) = collectMacros cdefs.def_macros icl_functions sizes_and_local_defs
(scanned_modules, icl_functions, cs)
......@@ -2635,8 +2639,9 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
ef_is_macro_fun = False }
(icl_functions, e_info, heaps, cs) = checkMacros cIclModIndex cdefs.def_macros icl_functions e_info heaps cs
(icl_functions, e_info, heaps, cs) = checkFunctions cIclModIndex cGlobalScope 0 nr_of_global_funs icl_functions e_info heaps cs
(icl_functions, e_info, heaps, cs) = checkFunctions cIclModIndex cGlobalScope icl_global_function_range.ir_from icl_global_function_range.ir_to icl_functions e_info heaps cs
cs = check_start_rule mod_type icl_global_function_range cs
cs = check_needed_modules_are_imported mod_name ".icl" cs
(icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error})
......@@ -2648,7 +2653,6 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(spec_functions, dcl_modules, class_instances, icl_functions, new_nr_of_functions, dcl_icl_conversions, var_heap, th_vars, expr_heap)
= collect_specialized_functions_in_dcl_module dcl_modules icl_common.com_instance_defs icl_functions nr_of_functions
hp_var_heap th_vars hp_expression_heap
icl_global_function_range = {ir_from = 0, ir_to = nr_of_global_funs}
icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions}
icl_specials = {ir_from = nr_of_functions, ir_to = new_nr_of_functions}
icl_functions = copy_instance_types instance_types { icl_fun \\ icl_fun <- [ icl_fun \\ icl_fun <-: icl_functions ] ++ spec_functions }
......@@ -2656,7 +2660,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(dcl_modules, class_instances, icl_functions, cs_predef_symbols)
= adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances icl_functions cs_predef_symbols
(untransformed_macro_funs_defs, icl_functions) = memcpy {ir_from = nr_of_global_funs, ir_to = first_inst_index } icl_functions
(untransformed_macro_funs_defs, icl_functions) = memcpy cdefs.def_macros icl_functions
(groups, icl_functions, dcl_modules, var_heap, expr_heap, cs_symbol_table, cs_error)
= partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex icl_functions
dcl_modules var_heap expr_heap cs_symbol_table cs_error
......@@ -2668,9 +2672,10 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
/* RWS
(dcl_modules, icl_mod, heaps, cs_error)
= compareDefImp (nr_of_global_funs, untransformed_macro_funs_defs) dcl_modules icl_mod heaps cs_error
= compareDefImp (cdefs.def_macros.ir_from, untransformed_macro_funs_defs) dcl_modules icl_mod heaps cs_error
*/
= (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file)
# icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs,
com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs }
......@@ -2681,6 +2686,23 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit = dcls_explicit} }
= (False, icl_mod, dcl_modules, {}, No, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file)
where
check_start_rule mod_kind {ir_from, ir_to} cs=:{cs_predef_symbols,cs_symbol_table}
# (pre_symb, cs_predef_symbols) = cs_predef_symbols![PD_Start]
({ste_kind, ste_index}, cs_symbol_table) = readPtr pre_symb.pds_ident.id_info cs_symbol_table
cs = { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table }
= case ste_kind of
STE_FunctionOrMacro _
| ir_from <= ste_index && ste_index < ir_to
-> { cs & cs_predef_symbols = { cs.cs_predef_symbols & [PD_Start] = { pre_symb & pds_def = ste_index, pds_module = cIclModIndex }}}
STE_Imported STE_DclFunction mod_index
-> { cs & cs_predef_symbols = { cs.cs_predef_symbols & [PD_Start] = { pre_symb & pds_def = ste_index, pds_module = mod_index }}}
_
-> case mod_kind of
MK_Main
-> { cs & cs_error = checkError "Start" " function not defined" cs.cs_error }
_
-> cs
convert_class_instances [pi=:{pi_members} : pins] next_fun_index
# ins_members = sort pi_members
(member_symbols, next_fun_index) = determine_indexes_of_members ins_members next_fun_index
......
......@@ -21,16 +21,16 @@ import RWSDebug
frontEndInterface :: !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface mod_ident search_paths predef_symbols hash_table files error io out
# (ok, mod, hash_table, error, predef_symbols, files)
= wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) error search_paths predef_symbols files
= wantModule cWantIclFile mod_ident (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
# (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, error, predef_symbols, files)
# (ok, mod, global_fun_range, mod_functions, dcl_mod, predef_mod, modules, hash_table, error, predef_symbols, files)
= scanModule (mod -*-> "Scanning") hash_table error search_paths predef_symbols files
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
# symbol_table = hash_table.hte_symbol_heap
(ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions, heaps, predef_symbols, symbol_table, error)
= checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table -*-> "Checking") error
= checkModule mod global_fun_range mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table -*-> "Checking") error
hash_table = { hash_table & hte_symbol_heap = symbol_table}
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
......@@ -41,7 +41,7 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials]
// (components, fun_defs, error) = showTypes components 0 fun_defs error
// (components, fun_defs, error) = showComponents components 0 True fun_defs error
// (fun_defs, error) = showFunctions array_instances fun_defs error
......@@ -62,7 +62,7 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
var_heap type_heaps expression_heap
(dcl_types, type_heaps, var_heap)
= convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap
(components, fun_defs, out) = showComponents components 0 False fun_defs out
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
= (predef_symbols,hash_table,files,error,io,out,
Yes { fe_icl = {icl_mod & icl_functions=fun_defs }
......
......@@ -675,7 +675,7 @@ where
convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps
# (expressions, heaps) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps
context_size = length expressions
| size rc_inst_members > 1 && context_size > 0
| False // RWS test size rc_inst_members > 1 && context_size > 0
# (let_binds, let_types, rev_dicts, hp_var_heap, hp_expression_heap)
= foldSt (bind_shared_dictionary (size rc_inst_members)) expressions ([], [], [], heaps.hp_var_heap, heaps.hp_expression_heap)
dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module (reverse rev_dicts) context_size dictionary_args
......
......@@ -5,4 +5,4 @@ import StdEnv
import syntax, parse, predef
scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files
-> (!Bool, !ScannedModule, !Int, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files)
-> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files)
This diff is collapsed.
......@@ -79,7 +79,9 @@ PD_variablePlaceholder :== 127
PD_StdDynamics :== 128
PD_undo_indirections :== 129
PD_NrOfPredefSymbols :== 130
PD_Start :== 130
PD_NrOfPredefSymbols :== 131
GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2
......
......@@ -77,7 +77,9 @@ PD_variablePlaceholder :== 127
PD_StdDynamics :== 128
PD_undo_indirections :== 129
PD_NrOfPredefSymbols :== 130
PD_Start :== 130
PD_NrOfPredefSymbols :== 131
(<<=) infixl
......@@ -146,6 +148,7 @@ where
<<- ("_unify", IC_Expression, PD_unify)
<<- ("StdDynamics", IC_Module, PD_StdDynamics)
<<- ("_undo_indirections", IC_Expression, PD_undo_indirections)
<<- ("Start", IC_Expression, PD_Start)
MakeTupleConsSymbIndex arity :== arity - 2 + cArity2TupleConsSymbIndex
......
......@@ -529,7 +529,7 @@ where
EI_Attribute sa_attr_nr
# (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env
| succ
---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr)
// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr)
-> (coercion_env, expr_heap, error)
-> (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error)
_
......
......@@ -1169,14 +1169,14 @@ InitFunEnv nr_of_fun_defs
= createArray nr_of_fun_defs EmptyFunctionType
//CreateInitialSymbolTypes :: ![Int] !u:{# FunDef} !{# CommonDefs } !*TypeState -> (!u:{# FunDef}, !*TypeState)
CreateInitialSymbolTypes common_defs [] defs_and_state
CreateInitialSymbolTypes start_index common_defs [] defs_and_state
= defs_and_state
CreateInitialSymbolTypes common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts)
CreateInitialSymbolTypes start_index common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts)
# (fd, fun_defs) = fun_defs![fun]
(pre_def_symbols, req_cons_variables, ts) = initial_symbol_type common_defs fd (pre_def_symbols, req_cons_variables, ts)
= CreateInitialSymbolTypes common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts)
(pre_def_symbols, req_cons_variables, ts) = initial_symbol_type (start_index == fun) common_defs fd (pre_def_symbols, req_cons_variables, ts)
= CreateInitialSymbolTypes start_index common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts)
where
initial_symbol_type common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} }
initial_symbol_type is_start_rule common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} }
(pre_def_symbols, req_cons_variables, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error})
# (st_args, ps) = addPropagationAttributesToATypes common_defs st_args
{ prop_type_heaps = ts_type_heaps, prop_td_infos = ts_td_infos,
......@@ -1193,8 +1193,8 @@ where
{ ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft lifted_args
{ fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted }},
ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps })
initial_symbol_type common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts)
# (st_gen, ts) = create_general_symboltype fun_arity fun_lifted ts
initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts)
# (st_gen, ts) = create_general_symboltype is_start_rule fun_arity fun_lifted ts
ts_type_heaps = ts.ts_type_heaps
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap)
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
......@@ -1204,12 +1204,16 @@ where
ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap})
create_general_symboltype :: !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState)
create_general_symboltype nr_of_args nr_of_lifted_args ts
# (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts
(tst_args, ts) = fresh_attributed_type_variables nr_of_lifted_args tst_args ts
(tst_result, ts) = freshAttributedVariable ts
= ({ tst_args = tst_args, tst_arity = nr_of_args + nr_of_lifted_args, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts)
create_general_symboltype :: !Bool !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState)
create_general_symboltype is_start_rule nr_of_args nr_of_lifted_args ts
| is_start_rule && nr_of_args > 0
# (tst_args, ts) = fresh_attributed_type_variables (nr_of_args - 1) [{at_attribute = TA_Unique, at_annotation = AN_Strict, at_type = TB BT_World }] ts
(tst_result, ts) = freshAttributedVariable ts
= ({ tst_args = tst_args, tst_arity = 1, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts)
# (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts
(tst_args, ts) = fresh_attributed_type_variables nr_of_lifted_args tst_args ts
(tst_result, ts) = freshAttributedVariable ts
= ({ tst_args = tst_args, tst_arity = nr_of_args + nr_of_lifted_args, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts)
fresh_attributed_type_variables :: !Int ![AType] !*TypeState -> (![AType], !*TypeState)
fresh_attributed_type_variables n vars ts
......@@ -1321,23 +1325,23 @@ specification_error type err
format = { form_properties = cAttributed, form_attr_position = No}
= { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' }
cleanUpAndCheckFunctionTypes [] _ defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
cleanUpAndCheckFunctionTypes [] _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
= (fun_defs, ts)
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] defs type_contexts coercion_env
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] start_index defs type_contexts coercion_env
attr_partition type_var_env attr_var_env (fun_defs, ts)
# (fd, fun_defs) = fun_defs![fun]
# (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun defs type_contexts
# (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
req_case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts
= cleanUpAndCheckFunctionTypes funs reqs defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
= cleanUpAndCheckFunctionTypes funs reqs start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
where
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun defs type_contexts case_and_let_exprs
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts case_and_let_exprs
coercion_env attr_partition type_var_env attr_var_env ts
# (env_type, ts) = ts!ts_fun_env.[fun]
# ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error}
= case env_type of
ExpandedType fun_type tmp_fun_type exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env
= cleanUpSymbolType is_start_rule cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
| ts_error.ea_ok
# (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error)
......@@ -1346,7 +1350,7 @@ where
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error })
UncheckedType exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env
= cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
......@@ -1401,24 +1405,17 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex
ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error }
ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions }
special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] }
// MW0 was # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
(type_error, fun_defs, predef_symbols, special_instances, ts=:{ts_error})
= type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
// MW0 was (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs
(fun_defs, ts_fun_env, ts_error=:{ea_ok=no_start_rule_error}) = update_function_types 0 comps ts.ts_fun_env fun_defs ts_error
# (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
(fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs
(type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps})
// MW0 was = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
// MW0 was { ts & ts_fun_env = ts_fun_env })
= type_instances specials.ir_from specials.ir_to class_instances ti
(type_error || not no_start_rule_error, fun_defs, predef_symbols, special_instances,
{ ts & ts_fun_env = ts_fun_env, ts_error = { ts_error & ea_ok = True }})
= type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
{ ts & ts_fun_env = ts_fun_env })
{si_array_instances, si_next_array_member_index, si_next_TC_member_index, si_TC_instances}= special_instances
(fun_defs, predef_symbols, ts_type_heaps) = convert_array_instances si_array_instances ti_common_defs fun_defs predef_symbols ts_type_heaps
type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances}
= (not type_error, fun_defs, { ir_from = fun_env_size, ir_to = si_next_array_member_index }, type_code_instances, ti_common_defs, ti_functions,
{hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file)
where
collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos
= foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos)
......@@ -1509,11 +1506,16 @@ where
# ({fun_symb}, fun_defs) = fun_defs![fun_index]
= ([fun_symb : names], fun_defs)
get_index_of_start_rule predef_symbols
# ({pds_def, pds_module}, predef_symbols) = predef_symbols![PD_Start]
| pds_def <> NoIndex && pds_module == cIclModIndex
= (pds_def, predef_symbols)
= (NoIndex, predef_symbols)
type_component comp class_instances ti=:{ti_common_defs} (type_error, fun_defs, predef_symbols, special_instances, ts)
# (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes ti_common_defs comp (fun_defs, predef_symbols, [], ts)
(names, fun_defs) = show_component comp fun_defs
(fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts /* (ts ---> names) */
# (start_index, predef_symbols) = get_index_of_start_rule predef_symbols
# (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes start_index ti_common_defs comp (fun_defs, predef_symbols, [], ts)
(fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts
#! nr_of_type_variables = ts.ts_var_store
# (subst, ts_type_heaps, ts_error)
......@@ -1546,7 +1548,7 @@ where
(subst, ts_fun_env) = expand_function_types comp subst ts.ts_fun_env
attr_var_env = createArray nr_of_attr_vars TA_None
var_env = { subst & [i] = TE \\ i <- [0..dec ts_var_store]}
(fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env
(fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs start_index ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env
(fun_defs, { ts & ts_error = ts_error, ts_fun_env = ts_fun_env, ts_type_heaps = ts_type_heaps,
ts_td_infos = ts_td_infos, ts_var_heap = os_var_heap, ts_expr_heap = os_symbol_heap })
| not ts.ts_error.ea_ok
......@@ -1667,50 +1669,31 @@ where
= (subst, ts_fun_env)
// MW0 was update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType})
update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} !*ErrorAdmin -> (!*{#FunDef}, !*{!FunctionType}, !.ErrorAdmin)
// MW0 was update_function_types group_index comps fun_env fun_defs
update_function_types group_index comps fun_env fun_defs error_admin
update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType})
update_function_types group_index comps fun_env fun_defs
| group_index == size comps
// MW0 was = (fun_defs, fun_env)
= (fun_defs, fun_env, error_admin)
= (fun_defs, fun_env)
#! comp = comps.[group_index]
// MW0 was # (fun_defs, fun_env) = update_function_types_in_component comp.group_members fun_env fun_defs
# (fun_defs, fun_env, error_admin) = update_function_types_in_component comp.group_members fun_env fun_defs error_admin
// MW0 was = update_function_types (inc group_index) comps fun_env fun_defs
= update_function_types (inc group_index) comps fun_env fun_defs error_admin
# (fun_defs, fun_env) = update_function_types_in_component comp.group_members fun_env fun_defs
= update_function_types (inc group_index) comps fun_env fun_defs
where
// MW0 was update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType})
update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} !*ErrorAdmin
-> (!*{#FunDef}, !*{!FunctionType}, !.ErrorAdmin)
// MW0 was update_function_types_in_component [ fun_index : funs ] fun_env fun_defs
update_function_types_in_component [ fun_index : funs ] fun_env fun_defs error_admin
update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType})
update_function_types_in_component [ fun_index : funs ] fun_env fun_defs
# (CheckedType checked_fun_type, fun_env) = fun_env![fun_index]
# (fd, fun_defs) = fun_defs![fun_index]
// MW0..
# is_start_rule = fd.fun_symb.id_name=="Start" && fd.fun_info.fi_def_level==1
error_admin = case is_start_rule of
False -> error_admin
_ -> check_type_of_start_rule fd checked_fun_type error_admin
// ..MW0
= case fd.fun_type of
No
// MW0 was -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }}
-> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }} error_admin
-> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }}
Yes fun_type
# nr_of_lifted_arguments = checked_fun_type.st_arity - fun_type.st_arity
| nr_of_lifted_arguments > 0
# fun_type = addLiftedArgumentsToSymbolType fun_type nr_of_lifted_arguments
checked_fun_type.st_args checked_fun_type.st_vars checked_fun_type.st_attr_vars checked_fun_type.st_context
// MW0 was -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }}
-> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} error_admin
// MW0 was -> update_function_types_in_component funs fun_env fun_defs
-> update_function_types_in_component funs fun_env fun_defs error_admin
// MW0 was update_function_types_in_component [] fun_env fun_defs
// MW0 was = (fun_defs, fun_env)
update_function_types_in_component [] fun_env fun_defs error_admin
= (fun_defs, fun_env, error_admin)
-> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }}
-> update_function_types_in_component funs fun_env fun_defs
update_function_types_in_component [] fun_env fun_defs
= (fun_defs, fun_env)
type_functions group ti cons_variables fun_defs ts
= mapSt (type_function ti) group (cons_variables, fun_defs, ts) // ((cons_variables, fun_defs, ts) ---> "[(") ---> ")]"
......@@ -1802,23 +1785,6 @@ where
CheckedType _
-> ts
// MW0..
check_type_of_start_rule fd checked_fun_type error_admin
| not (isEmpty checked_fun_type.st_context)
= checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "must not be overloaded" error_admin
| isEmpty checked_fun_type.st_args
= error_admin
| length checked_fun_type.st_args > 1
= checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "should have arity 0 or 1" error_admin
= case checked_fun_type.st_args of
[] -> error_admin
[{at_type=TB BT_World}]
-> error_admin
[{at_type=TV _}]
-> error_admin
_ -> checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "argument must be of type World" error_admin
// ..MW0
instance <<< AttrCoercion
where
(<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< '~' <<< ac_offered
......
......@@ -32,7 +32,7 @@ extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
cSpecifiedType :== True
cDerivedType :== False
cleanUpSymbolType :: !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition
cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition
!*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin
-> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
......
......@@ -223,6 +223,10 @@ liftedError var err
# err = errorHeading "Type error" err
= { err & ea_file = err.ea_file <<< "type variable of type of lifted argument " <<< var <<< " appears in the specified type\n" }
startRuleError mess err
# err = errorHeading "Type error" err
= { err & ea_file = err.ea_file <<< mess }
extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
extendSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_extra_args type_heaps
| nr_of_extra_args > 0
......@@ -255,10 +259,10 @@ newAttributedVariable var_number (variables, attributes, type_heaps=:{th_vars,th
cSpecifiedType :== True
cDerivedType :== False