diff options
| author | clean | 2000-09-27 10:27:54 +0000 |
|---|---|---|
| committer | clean | 2000-09-27 10:27:54 +0000 |
| commit | d178557e591ca40ccbcd5dd967182a8eaa6eaef8 (patch) | |
| tree | f581ca424180415c6ac5e60636026cf020ebbbc5 | |
| parent | bugfix: list inferred types printed types like f :: .[.a] instead of (diff) | |
optimizations and caching of dcl modules (without trans.icl)
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@232 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
35 files changed, 2190 insertions, 702 deletions
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl index b40a1db..b772a73 100644 --- a/frontend/StdCompare.icl +++ b/frontend/StdCompare.icl @@ -117,6 +117,7 @@ where = compare_indexes symb1 symb2 with compare_indexes (SK_Function i1) (SK_Function i2) = i1 =< i2 + compare_indexes (SK_LocalMacroFunction i1) (SK_LocalMacroFunction i2) = i1 =< i2 // compare_indexes (SK_ClassRecord i1) (SK_ClassRecord i2) = i1 =< i2 compare_indexes (SK_Constructor i1) (SK_Constructor i2) = i1 =< i2 // compare_indexes (SK_DeltaFunction i1) (SK_DeltaFunction i2) = i1 =< i2 diff --git a/frontend/analtypes.dcl b/frontend/analtypes.dcl index ae9b48d..b955243 100644 --- a/frontend/analtypes.dcl +++ b/frontend/analtypes.dcl @@ -2,7 +2,6 @@ definition module analtypes import checksupport, typesupport - -analTypeDefs :: !{#CommonDefs} !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) +analTypeDefs :: !{#CommonDefs} !ModuleNumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) instance <<< TypeKind diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index b143d0b..3763652 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -243,9 +243,11 @@ where check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState -> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState) */ + new_local_kind_variables :: .[ATypeVar] *(*Heap TypeVarInfo,*Heap .KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo); new_local_kind_variables td_args (type_var_heap, as_kind_heap) = foldSt new_kind td_args (True, type_var_heap, as_kind_heap) where + new_kind :: ATypeVar *(.Bool,*Heap TypeVarInfo,*Heap .KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo); new_kind {atv_variable={tv_info_ptr},atv_attribute} (coercible, type_var_heap, kind_heap) # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = (coercible && is_not_a_variable atv_attribute, type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), @@ -293,6 +295,7 @@ emptyIdent name :== { id_name = name, id_info = nilPtr } newKindVariables td_args (type_var_heap, as_kind_heap) = mapSt new_kind td_args (type_var_heap, as_kind_heap) where + new_kind :: ATypeVar *(*Heap TypeVarInfo,*Heap .KindInfo) -> (!.TypeKind,!(!.Heap TypeVarInfo,!.Heap KindInfo)); new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))) @@ -451,13 +454,16 @@ where is_a_top_var var_number [] = False +//import RWSDebug -analTypeDefs :: !{#CommonDefs} !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) -analTypeDefs modules heaps error +analTypeDefs :: !{#CommonDefs} !ModuleNumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) +analTypeDefs modules used_module_numbers heaps error // #! modules = modules ---> "analTypeDefs" - # sizes = [ size mod.com_type_defs - size mod.com_class_defs \\ mod <-: modules ] +// # sizes = [ size mod.com_type_defs - size mod.com_class_defs \\ mod <-: modules ] +// # used_module_numbers = used_module_numbers <<- used_module_numbers + # sizes = [ if (in_module_number_set module_n used_module_numbers) (size mod.com_type_defs - size mod.com_class_defs) 0 \\ mod <-: modules & module_n<-[0..]] - check_marks = { createArray nr_of_types AS_NotChecked \\ nr_of_types <- sizes } + check_marks = { createArray nr_of_types AS_NotChecked \\ nr_of_types <- sizes } type_def_infos = { createArray nr_of_types EmptyTypeDefInfo \\ nr_of_types <- sizes } as = { as_check_marks = check_marks, as_kind_heap = newHeap, as_heaps = heaps, as_td_infos = type_def_infos, @@ -472,7 +478,6 @@ where anal_type_defs _ _ [] as = as - anal_type_def modules mod_index type_index as=:{as_check_marks} | as_check_marks.[mod_index].[type_index] == AS_NotChecked # (_, (_, as)) = analTypeDef modules mod_index type_index as diff --git a/frontend/analunitypes.dcl b/frontend/analunitypes.dcl index 8afc662..613190d 100644 --- a/frontend/analunitypes.dcl +++ b/frontend/analunitypes.dcl @@ -11,4 +11,3 @@ signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*T propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) - diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index cbe99cf..f099825 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -60,7 +60,7 @@ removeTopClasses _ _ , scs_rec_appls :: ![RecTypeApplication (Sign, [SignClassification])] } -determineSignClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![SignClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos +determineSignClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![SignClassification] !{# CommonDefs} !*TypeVarHeap !*TypeDefInfos -> (!SignClassification, !*TypeVarHeap,!*TypeDefInfos) determineSignClassOfTypeDef type_index module_index td_args {tdi_classification,tdi_cons_vars,tdi_group_vars,tdi_group,tdi_group_nr} hio_signs ci type_var_heap td_infos @@ -309,8 +309,7 @@ propClassification type_index module_index hio_props defs type_var_heap td_infos (td_info, td_infos) = td_infos![module_index].[type_index] = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos - -determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos +determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] !{# CommonDefs} !*TypeVarHeap !*TypeDefInfos -> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos) determinePropClassOfTypeDef type_index module_index td_args {tdi_classification, tdi_kinds, tdi_group, tdi_group_vars, tdi_cons_vars, tdi_group_nr} hio_props ci type_var_heap td_infos diff --git a/frontend/check.dcl b/frontend/check.dcl index e69603a..8f482e0 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -4,8 +4,8 @@ import syntax, transform, checksupport, typesupport, predef cPredefinedModuleIndex :== 1 -checkModule :: !ScannedModule !IndexRange ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File - -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) +checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps + -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index) diff --git a/frontend/check.icl b/frontend/check.icl index df7b7b2..daf7d7b 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2,7 +2,7 @@ implementation module check import StdEnv -import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef //, RWSDebug import explicitimports, comparedefimp cPredefinedModuleIndex :== 1 @@ -248,7 +248,7 @@ where # class_def = dcl_mod.dcl_common.com_class_defs.[ste_index] = (ste_index, dcl_index, class_def, class_defs, modules) get_class_def _ mod_index class_defs modules - = (NotFound, cIclModIndex, abort "no class definition", class_defs, modules) + = (NotFound, -1/*cIclModIndex*/, abort "no class definition", class_defs, modules) checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState) @@ -567,14 +567,15 @@ where No -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error }) + check_and_rearrange_fields :: Int Int {#FieldSymbol} ![Bind ParsedExpr (Ident,[Global .Int])] *ErrorAdmin -> ([Bind ParsedExpr .(Global FieldSymbol)],!.ErrorAdmin); check_and_rearrange_fields mod_index field_index fields field_ass cs_error | field_index < size fields # (field_expr, field_ass) = look_up_field mod_index fields.[field_index] field_ass (field_exprs, cs_error) = check_and_rearrange_fields mod_index (inc field_index) fields field_ass cs_error = ([field_expr : field_exprs], cs_error) - | isEmpty field_ass - = ([], cs_error) - = ([], foldSt field_error field_ass cs_error) + | isEmpty field_ass + = ([], cs_error) + = ([], foldSt field_error field_ass cs_error) where look_up_field mod_index field [] @@ -620,11 +621,9 @@ where // , ei_fun_kind :: !FunKind } - cIsInExpressionList :== True cIsNotInExpressionList :== False - :: UnfoldMacroState = { ums_var_heap :: !.VarHeap , ums_modules :: !.{# DclModule} @@ -701,12 +700,12 @@ checkPatternConstructor :: !Index !Bool !SymbolTableEntry !Ident !(Optional (Bin -> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState); checkPatternConstructor _ _ {ste_kind = STE_Empty} ident _ ps e_info cs=:{cs_error} = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident " not defined" cs_error }) -checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var ps=:{ps_fun_defs} e_info cs=:{cs_error} +checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var ps=:{ps_fun_defs} e_info cs=:{cs_error,cs_x} # ({fun_symb,fun_arity,fun_kind,fun_priority},ps_fun_defs) = ps_fun_defs![ste_index] ps = { ps & ps_fun_defs = ps_fun_defs } | fun_kind == FK_Macro | is_expr_list - # macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cIclModIndex } + # macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cs_x.x_main_dcl_module_n } = (AP_Constant APK_Macro macro_symbol fun_priority, ps, e_info, cs) | fun_arity == 0 # (pattern, ps, ef_modules, ef_cons_defs, cs_error) @@ -896,9 +895,9 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs = (opt_var, error) */ -checkPattern (PE_DynamicPattern pattern type) opt_var p_input accus ps e_info cs +checkPattern (PE_DynamicPattern pattern type) opt_var p_input accus ps e_info cs=:{cs_x} # (dyn_pat, accus, ps, e_info, cs) = checkPattern pattern No p_input accus ps e_info cs - = (AP_Dynamic dyn_pat type opt_var, accus, ps, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics }) + = (AP_Dynamic dyn_pat type opt_var, accus, ps, e_info, { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdDynamics }) checkPattern (PE_Basic basic_value) opt_var p_input accus ps e_info cs = (AP_Basic basic_value opt_var, accus, ps, e_info, cs) @@ -1072,13 +1071,13 @@ where check_id_expression :: !SymbolTableEntry !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) - check_id_expression {ste_kind = STE_Empty} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error,cs_predef_symbols} + check_id_expression {ste_kind = STE_Empty} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error,cs_predef_symbols,cs_x} # ({pds_ident=from_ident}) = cs_predef_symbols.[PD_From] ({pds_ident=from_then_ident}) = cs_predef_symbols.[PD_FromThen] ({pds_ident=from_to_ident}) = cs_predef_symbols.[PD_FromTo] ({pds_ident=from_then_to_ident}) = cs_predef_symbols.[PD_FromThenTo] | id==from_ident || id==from_then_ident || id==from_to_ident || id==from_then_to_ident - = (EE, free_vars, e_state, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdEnum}) + = (EE, free_vars, e_state, e_info, { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdEnum}) // instead of giving an error message remember that StdEnum should have been imported. // Error will be given in function check_needed_modules_are_imported # ({pds_ident=createArray_ident}) = cs_predef_symbols.[PD__CreateArrayFun] @@ -1086,7 +1085,7 @@ where ({pds_ident=update_ident}) = cs_predef_symbols.[PD_ArrayUpdateFun] ({pds_ident=usize_ident}) = cs_predef_symbols.[PD_UnqArraySizeFun] | id==createArray_ident || id==uselect_ident || id==update_ident || id==usize_ident - = (EE, free_vars, e_state, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdArray}) + = (EE, free_vars, e_state, e_info, { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdArray}) // instead of giving an error message remember that StdArray should have been be imported. // Error will be given in function check_needed_modules_are_imported = (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "undefined" cs_error }) @@ -1109,16 +1108,20 @@ where determine_info_of_symbol :: !SymbolTableEntry !SymbolPtr !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info - e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info cs=:{cs_symbol_table} + e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info=:{ef_is_macro_fun} cs=:{cs_symbol_table,cs_x} # ({fun_symb,fun_arity,fun_kind,fun_priority}, es_fun_defs) = es_fun_defs![ste_index] - # index = { glob_object = ste_index, glob_module = cIclModIndex } + # index = { glob_object = ste_index, glob_module = cs_x.x_main_dcl_module_n } | is_called_before ei_fun_index calls | fun_kind == FK_Macro = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) - = (SK_Function index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) +// = (SK_Function index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) + # symbol_kind = if ef_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index) + = (symbol_kind, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} e_state = { e_state & es_fun_defs = es_fun_defs, es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} - = (if (fun_kind == FK_Macro) (SK_Macro index) (SK_Function index), fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) +// = (if (fun_kind == FK_Macro) (SK_Macro index) (SK_Function index), fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + # symbol_kind = if (fun_kind == FK_Macro) (SK_Macro index) (if ef_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index)) + = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) where is_called_before caller_index [] = False @@ -1545,6 +1548,7 @@ checkExpression free_vars rec=:(PE_Record record opt_type fields) e_input=:{ei_e where remove_fields binds = [ bind_src \\ {bind_src} <- binds ] + check_field_exprs :: [FreeVar] [Bind ParsedExpr (Global FieldSymbol)] Int RecordKind ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState -> *(![.Bind Expression (Global FieldSymbol)],![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_field_exprs free_vars [] field_nr record_kind e_input e_state e_info cs = ([], free_vars, e_state, e_info, cs) check_field_exprs free_vars [field_expr : field_exprs] field_nr record_kind e_input e_state e_info cs @@ -1553,6 +1557,7 @@ where (exprs, free_vars, e_state, e_info, cs) = check_field_exprs free_vars field_exprs (inc field_nr) record_kind e_input e_state e_info cs = ([expr : exprs], free_vars, e_state, e_info, cs) + check_field_expr :: [FreeVar] (Bind ParsedExpr (Global FieldSymbol)) Int RecordKind ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!.Bind Expression (Global FieldSymbol),![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_field_expr free_vars field=:{bind_src = PE_Empty, bind_dst={glob_object={fs_var,fs_name,fs_index},glob_module}} field_nr record_kind e_input e_state e_info cs # (expr, free_vars, e_state, e_info, cs) = checkIdentExpression cIsNotInExpressionList free_vars fs_var e_input e_state e_info cs @@ -1585,12 +1590,12 @@ where get_field_var _ = ({ id_name = "** ERRONEOUS **", id_info = nilPtr }, nilPtr) -checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expr_heap,es_dynamics} e_info cs +checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expr_heap,es_dynamics} e_info cs=:{cs_x} # (dyn_info_ptr, es_expr_heap) = newPtr (EI_Dynamic opt_type) es_expr_heap (dyn_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input {e_state & es_dynamics = [dyn_info_ptr : es_dynamics], es_expr_heap = es_expr_heap } e_info cs = (DynamicExpr { dyn_expr = dyn_expr, dyn_opt_type = opt_type, dyn_info_ptr = dyn_info_ptr, dyn_type_code = TCE_Empty, dyn_uni_vars = [] }, - free_vars, e_state, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics }) + free_vars, e_state, e_info, { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdDynamics }) checkExpression free_vars (PE_Basic basic_value) e_input e_state e_info cs # (basic_type, cs) = typeOfBasicValue basic_value cs @@ -1717,6 +1722,7 @@ buildLetExpression let_strict_binds let_lazy_binds expr expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap = (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap) +checkLhssOfLocalDefs :: .Int .Int LocalDefs *ExpressionState *ExpressionInfo *CheckState -> (!.[NodeDef AuxiliaryPattern],!(![Ident],![ArrayPattern]),!.ExpressionState,!.ExpressionInfo,!.CheckState); checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_nodes}) e_state=:{es_var_heap,es_fun_defs} e_info cs # (loc_defs, accus, {ps_fun_defs,ps_var_heap}, e_info, cs) = check_patterns loc_nodes {pi_def_level = def_level, pi_mod_index = mod_index, pi_is_node_pattern = True } ([], []) @@ -1919,7 +1925,6 @@ where (expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars alt_expr e_input e_state e_info cs = (let_vars_list, [(let_binds, guard, expr, alt_ident) : rev_guarded_exprs], ei_expr_level, free_vars, e_state, e_info, cs ) - // JVG: added type check_unguarded_expression :: [FreeVar] ExprWithLocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals,ewl_position} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # this_expr_level = inc ei_expr_level @@ -1946,7 +1951,8 @@ where = symbol_table remove_seq_let_vars level [let_vars : let_vars_list] symbol_table = remove_seq_let_vars (dec level) let_vars_list (removeLocalIdentsFromSymbolTable level let_vars symbol_table) - + + check_sequential_lets :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(![.([Bind Expression FreeVar],![Bind Expression FreeVar])],!u:[[Ident]],!Int,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_sequential_lets free_vars [seq_let:seq_lets] let_vars_list e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # ei_expr_level = inc ei_expr_level @@ -1969,7 +1975,6 @@ where check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs = ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) - // JVG: added type check_sequential_let :: [FreeVar] NodeDefWithLocals ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!AuxiliaryPattern,!(![Ident],![ArrayPattern]),![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState); check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals, ndwl_position} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # cs = pushErrorAdmin (newPosition {id_name="node definition", id_info=nilPtr} ndwl_position) cs @@ -2004,6 +2009,7 @@ determinePatternVariable No var_heap # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap = ({ bind_src = newVarId "_x", bind_dst = new_info_ptr }, var_heap) +convertSubPatterns :: [AuxiliaryPattern] Expression Position *(Heap VarInfo) *(Heap ExprInfo) u:[Ptr ExprInfo] *CheckState -> *(!.[FreeVar],!Expression,!Position,!*Heap VarInfo,!*Heap ExprInfo,!u:[Ptr ExprInfo],!*CheckState); convertSubPatterns [] result_expr pattern_position var_store expr_heap opt_dynamics cs = ([], result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) convertSubPatterns [pattern : patterns] result_expr pattern_position var_store expr_heap opt_dynamics cs @@ -2013,6 +2019,7 @@ convertSubPatterns [pattern : patterns] result_expr pattern_position var_store e = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs = ([var_arg : var_args], result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern :: AuxiliaryPattern Expression Position *(Heap VarInfo) *(Heap ExprInfo) u:[Ptr ExprInfo] *CheckState -> *(!FreeVar,!Expression,!Position,!*Heap VarInfo,!*Heap ExprInfo,!u:[Ptr ExprInfo],!*CheckState); convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } @@ -2243,7 +2250,7 @@ where transform_patterns_into_cases [] _ result_expr pattern_position var_store expr_heap opt_dynamics cs = (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) - + transform_pattern_into_cases :: !AuxiliaryPattern !FreeVar !Expression !Position !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState -> (!Expression, !Position, !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_name} result_expr pattern_position @@ -2417,14 +2424,13 @@ checkMacros mod_index range fun_defs e_info=:{ef_is_macro_fun=ef_is_macro_fun_ol { cs & cs_symbol_table = cs_symbol_table, cs_predef_symbols = cs_predef_symbols, cs_error = cs_error }) checkInstanceBodies :: !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps, !*CheckState); -checkInstanceBodies {ir_from, ir_to} fun_defs e_info heaps cs - = checkFunctions cIclModIndex cGlobalScope ir_from ir_to fun_defs e_info heaps cs +checkInstanceBodies {ir_from, ir_to} fun_defs e_info heaps cs=:{cs_x} + = checkFunctions cs_x.x_main_dcl_module_n cGlobalScope ir_from ir_to fun_defs e_info heaps cs instance < FunDef where (<) fd1 fd2 = fd1.fun_symb.id_name < fd2.fun_symb.id_name - createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} = { com_type_defs = { type \\ type <- def_types } , com_cons_defs = { cons \\ cons <- def_constructors } @@ -2433,16 +2439,18 @@ createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def , com_member_defs = { member \\ member <- def_members } , com_instance_defs = { next_instance \\ next_instance <- def_instances } } - -IsMainDclMod is_dcl module_index :== is_dcl && module_index == cIclModIndex +//IsMainDclMod is_dcl module_index :== is_dcl && module_index == cIclModIndex +array_plus_list a [] = a +array_plus_list a l = arrayPlusList a l checkCommonDefinitions :: !Bool !Index !*CommonDefs !*{# DclModule} !*TypeHeaps !*VarHeap !*CheckState -> (!*CommonDefs, !*{# DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs + #! is_main_dcl_mod = is_dcl && module_index == cs.cs_x.x_main_dcl_module_n # (com_type_defs, com_cons_defs, com_selector_defs, modules, var_heap, type_heaps, cs) - = checkTypeDefs (IsMainDclMod is_dcl module_index) common.com_type_defs module_index + = checkTypeDefs is_main_dcl_mod common.com_type_defs module_index common.com_cons_defs common.com_selector_defs modules var_heap type_heaps cs (com_class_defs, com_member_defs, com_type_defs, modules, type_heaps, cs) = checkTypeClasses 0 module_index common.com_class_defs common.com_member_defs com_type_defs modules type_heaps cs @@ -2450,12 +2458,19 @@ checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs = checkMemberTypes module_index com_member_defs com_type_defs com_class_defs modules type_heaps var_heap cs (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, type_heaps, cs) = checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs modules type_heaps cs + + (size_com_type_defs,com_type_defs) = usize com_type_defs + (size_com_selector_defs,com_selector_defs) = usize com_selector_defs + (size_com_cons_defs,com_cons_defs) = usize com_cons_defs + (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs) - = createClassDictionaries module_index com_class_defs modules (size com_type_defs) (size com_selector_defs) - (size com_cons_defs) type_heaps.th_vars var_heap cs - com_type_defs = { type_def \\ type_def <- [ type_def \\ type_def <-: com_type_defs ] ++ new_type_defs } - com_selector_defs = { sel_def \\ sel_def <- [ sel_def \\ sel_def <-: com_selector_defs ] ++ new_selector_defs } - com_cons_defs = { cons_def \\ cons_def <- [ cons_def \\ cons_def <-: com_cons_defs ] ++ new_cons_defs } + = createClassDictionaries module_index com_class_defs modules size_com_type_defs size_com_selector_defs size_com_cons_defs + type_heaps.th_vars var_heap cs + + com_type_defs = array_plus_list com_type_defs new_type_defs + com_selector_defs = array_plus_list com_selector_defs new_selector_defs + com_cons_defs = array_plus_list com_cons_defs new_cons_defs + = ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs, com_member_defs = com_member_defs, com_instance_defs = com_instance_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs) @@ -2477,17 +2492,17 @@ collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_ sizes = { sizes & [cMemberDefs] = size } = (sizes, defs) where - type_def_to_dcl {td_name, td_pos} (dcl_index, decls) + type_def_to_dcl {td_name, td_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = td_name, dcl_pos = td_pos, dcl_kind = STE_Type, dcl_index = dcl_index } : decls]) - cons_def_to_dcl {cons_symb, cons_pos} (dcl_index, decls) + cons_def_to_dcl {cons_symb, cons_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = cons_symb, dcl_pos = cons_pos, dcl_kind = STE_Constructor, dcl_index = dcl_index } : decls]) - selector_def_to_dcl {sd_symb, sd_field, sd_pos} (dcl_index, decls) + selector_def_to_dcl {sd_symb, sd_field, sd_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = sd_field, dcl_pos = sd_pos, dcl_kind = STE_Field sd_symb, dcl_index = dcl_index } : decls]) - class_def_to_dcl {class_name, class_pos} (dcl_index, decls) + class_def_to_dcl {class_name, class_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = class_name, dcl_pos = class_pos, dcl_kind = STE_Class, dcl_index = dcl_index } : decls]) - member_def_to_dcl {me_symb, me_pos} (dcl_index, decls) + member_def_to_dcl {me_symb, me_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = me_symb, dcl_pos = me_pos, dcl_kind = STE_Member, dcl_index = dcl_index } : decls]) - instance_def_to_dcl {ins_ident, ins_pos} (dcl_index, decls) + instance_def_to_dcl {ins_ident, ins_pos} (dcl_index, decls) = (inc dcl_index, [{ dcl_ident = ins_ident, dcl_pos = ins_pos, dcl_kind = STE_Instance, dcl_index = dcl_index } : decls]) collectMacros {ir_from,ir_to} macro_defs sizes_defs @@ -2508,11 +2523,89 @@ where # ({fun_symb, fun_pos}, fun_defs) = fun_defs![dcl_index] = ([{ dcl_ident = fun_symb, dcl_pos = fun_pos, dcl_kind = STE_FunctionOrMacro [], dcl_index = dcl_index } : defs], fun_defs) -combineDclAndIclModule :: !ModuleKind !*{#DclModule} ![Declaration] !(CollectedDefinitions b c) !*{#Int} !*CheckState -> (!*{#DclModule},![Declaration],!CollectedDefinitions b c,!*{#Int},!*CheckState); +renumber_icl_definitions_as_dcl_definitions MK_Main icl_decl_symbols modules cdefs icl_sizes cs + = (icl_decl_symbols,modules,cdefs,cs) +renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl_sizes cs + #! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n + # (dcl_mod,modules) = modules![main_dcl_module_n] + # (Yes conversion_table) = dcl_mod.dcl_conversions + # icl_to_dcl_index_table = {create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table \\ table_size <-: icl_sizes & dcl_to_icl_table <-: conversion_table } + with + create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table + # icl_to_dcl_index_table_for_kind = {createArray table_size NoIndex & [dcl_to_icl_table.[dcl_index]]=dcl_index \\ dcl_index<- [0..size dcl_to_icl_table-1]} + #! max_index=size icl_to_dcl_index_table_for_kind-1 + # icl_to_dcl_index_table_for_kind = number_NoIndex_elements max_index max_index icl_to_dcl_index_table_for_kind + with + number_NoIndex_elements :: Int Int *{#Int} -> .{#Int}; + number_NoIndex_elements index free_position_index icl_to_dcl_index_table_for_kind + | index>=0 + | icl_to_dcl_index_table_for_kind.[index]==NoIndex + = number_NoIndex_elements (index-1) (free_position_index-1) {icl_to_dcl_index_table_for_kind & [index]=free_position_index} + = number_NoIndex_elements (index-1) free_position_index icl_to_dcl_index_table_for_kind + = icl_to_dcl_index_table_for_kind + = icl_to_dcl_index_table_for_kind + # modules = {modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table}} + # (icl_decl_symbols,cdefs) = renumber_icl_decl_symbols icl_decl_symbols cdefs + with + renumber_icl_decl_symbols [] cdefs + = ([],cdefs) + renumber_icl_decl_symbols [icl_decl_symbol : icl_decl_symbols] cdefs + # (icl_decl_symbol,cdefs) = renumber_icl_decl_symbol icl_decl_symbol cdefs + # (icl_decl_symbols,cdefs) = renumber_icl_decl_symbols icl_decl_symbols cdefs + = ([icl_decl_symbol : icl_decl_symbols],cdefs) + where + renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Type, dcl_index} cdefs + # (type_def,cdefs) = cdefs!com_type_defs.[dcl_index] + # type_def = renumber_type_def type_def + # cdefs={cdefs & com_type_defs.[dcl_index]=type_def} + = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cTypeDefs,dcl_index]},cdefs) + where + renumber_type_def td=:{td_rhs = AlgType conses} + # conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses] + = { td & td_rhs = AlgType conses} + renumber_type_def td=:{td_rhs = RecordType rt=:{rt_constructor,rt_fields}} + # rt_constructor = {rt_constructor & ds_index=icl_to_dcl_index_table.[cConstructorDefs,rt_constructor.ds_index]} + # rt_fields = {{field & fs_index=icl_to_dcl_index_table.[cSelectorDefs,field.fs_index]} \\ field <-: rt_fields} + = {td & td_rhs=RecordType {rt_constructor=rt_constructor,rt_fields=rt_fields}} + renumber_type_def td + = td + renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Constructor, dcl_index} cdefs + = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cConstructorDefs,dcl_index]},cdefs) + renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Field _, dcl_index} cdefs + = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cSelectorDefs,dcl_index]},cdefs) + renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Member, dcl_index} cdefs + = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cMemberDefs,dcl_index]},cdefs) + renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Class, dcl_index} cdefs + # (class_def,cdefs) = cdefs!com_class_defs.[dcl_index] + # class_members = {{class_member & ds_index=icl_to_dcl_index_table.[cMemberDefs,class_member.ds_index]} \\ class_member <-: class_def.class_members} + # class_def = {class_def & class_members=class_members} + # cdefs = {cdefs & com_class_defs.[dcl_index] =class_def} + = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cClassDefs,dcl_index]},cdefs) + renumber_icl_decl_symbol icl_decl_symbol cdefs + = (icl_decl_symbol,cdefs) + # cdefs=reorder_common_definitions cdefs + with + reorder_common_definitions {com_type_defs,com_cons_defs,com_selector_defs,com_class_defs,com_member_defs,com_instance_defs} + # com_type_defs=reorder_array com_type_defs icl_to_dcl_index_table.[cTypeDefs] + # com_cons_defs=reorder_array com_cons_defs icl_to_dcl_index_table.[cConstructorDefs] + # com_selector_defs=reorder_array com_selector_defs icl_to_dcl_index_table.[cSelectorDefs] + # com_class_defs=reorder_array com_class_defs icl_to_dcl_index_table.[cClassDefs] + # com_member_defs=reorder_array com_member_defs icl_to_dcl_index_table.[cMemberDefs] + = {com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs,com_class_defs=com_class_defs,com_member_defs=com_member_defs,com_instance_defs=com_instance_defs} + where + reorder_array array index_array + # new_array={e\\e<-:array} + = {new_array & [index_array.[i]]=e \\ e<-:array & i<-[0..]} + # conversion_table = {if (kind_index<=cMemberDefs) {i\\i<-[0..size table-1]} table \\ table<-:conversion_table & kind_index<-[0..]} + # modules = {modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} + = (icl_decl_symbols,modules,cdefs,cs) + +combineDclAndIclModule :: ModuleKind *{#.DclModule} [.Declaration] (CollectedDefinitions a b) *{#.Int} *CheckState -> (!*{#DclModule},![Declaration],!CollectedDefinitions a b,!*{#Int},!.CheckState); combineDclAndIclModule MK_Main modules icl_decl_symbols icl_definitions icl_sizes cs = (modules, icl_decl_symbols, icl_definitions, icl_sizes, cs) combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs - # (dcl_mod=:{dcl_declared={dcls_local},dcl_macros, dcl_sizes, dcl_common}, modules) = modules![cIclModIndex] + #! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n + # (dcl_mod=:{dcl_declared={dcls_local},dcl_macros, dcl_sizes, dcl_common}, modules) = modules![main_dcl_module_n] cs = addGlobalDefinitionsToSymbolTable icl_decl_symbols cs @@ -2523,7 +2616,7 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs = foldSt (add_dcl_definition dcl_common) moved_dcl_defs ([], [], [], [], [], cs) cs_symbol_table = removeDeclarationsFromSymbolTable icl_decl_symbols cGlobalScope cs.cs_symbol_table - = ( { modules & [cIclModIndex] = { dcl_mod & dcl_conversions = Yes conversion_table }} + = ( { modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table }} , icl_decl_symbols , { icl_definitions & def_types = my_append icl_definitions.def_types new_type_defs @@ -2532,7 +2625,7 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs , def_classes = my_append icl_definitions.def_classes new_class_defs , def_members = my_append icl_definitions.def_members new_member_defs } - , icl_sizes + , icl_sizes , { cs & cs_symbol_table = cs_symbol_table } ) where @@ -2655,16 +2748,31 @@ where (<=<) infixl (<=<) state fun :== fun state - -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} icl_global_function_range fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file +checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps + -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef}, !Int,!*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) +checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod scanned_modules dcl_modules functions_and_macros predef_symbols symbol_table err_file heaps + # (optional_pre_def_mod,predef_symbols) + = case size dcl_modules of + 0 # (predef_mod,predef_symbols) = buildPredefinedModule predef_symbols + -> (Yes predef_mod,predef_symbols) + _ -> (No,predef_symbols) + # (mod_name,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,local_defs,icl_functions,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) + = check_module1 m icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules functions_and_macros dcl_module_n_in_cache predef_symbols symbol_table err_file + # icl_instance_range = {ir_from = first_inst_index, ir_to = nr_of_functions} +// # (ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, heaps, cs_predef_symbols, cs_symbol_table, ea_file) + = check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range nr_of_functions n_functions_and_macros_in_dcl_modules optional_pre_def_mod local_defs icl_functions init_dcl_modules cdefs sizes heaps cs +// = (ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, heaps, cs_predef_symbols, cs_symbol_table, ea_file) + +check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules functions_and_macros dcl_module_n_in_cache predef_symbols symbol_table err_file # error = {ea_file = err_file, ea_loc = [], ea_ok = True } - first_inst_index = length fun_defs - + first_inst_index = length fun_defs + size functions_and_macros (inst_fun_defs, def_instances) = convert_class_instances cdefs.def_instances first_inst_index - icl_functions = { next_fun \\ next_fun <- fun_defs ++ inst_fun_defs } + + new_icl_functions = { next_fun \\ next_fun <- fun_defs ++ inst_fun_defs } + + icl_functions = {if (i<size functions_and_macros) functions_and_macros.[i] new_icl_functions.[i-size functions_and_macros] \\ i<-[0..size functions_and_macros+size new_icl_functions-1]} + cdefs = { cdefs & def_instances = def_instances } #! nr_of_functions = size icl_functions @@ -2672,45 +2780,175 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (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) - = add_modules_to_symbol_table [ dcl_mod, pre_def_mod : scanned_modules ] 0 icl_functions - { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_needed_modules = 0 } - - init_dcl_modules = [ initialDclModule scanned_module \\ scanned_module <- scanned_modules ] - (icl_sizes_without_added_dcl_defs, sizes) = memcpy sizes - (dcl_modules, local_defs, cdefs, _, cs) - = combineDclAndIclModule mod_type { dcl_module \\ dcl_module <- init_dcl_modules } local_defs cdefs sizes cs + main_dcl_module_n = if (dcl_module_n_in_cache<>NoIndex) dcl_module_n_in_cache (size dcl_modules) + cs = { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_x= {x_needed_modules=0,x_main_dcl_module_n=main_dcl_module_n}} + + (scanned_modules, icl_functions, cs) = add_dcl_module_predef_module_and_modules_to_symbol_table optional_dcl_mod optional_pre_def_mod scanned_modules (size dcl_modules) icl_functions cs + + init_new_dcl_modules = { initialDclModule scanned_module module_n \\ scanned_module <- scanned_modules & module_n<-[size dcl_modules..]} + + init_dcl_modules = {if (i<size dcl_modules) dcl_modules.[i] init_new_dcl_modules.[i-size dcl_modules] \\ i<-[0..size dcl_modules+size init_new_dcl_modules-1]} + = (mod_name,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,local_defs,icl_functions,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) + + where + add_dcl_module_predef_module_and_modules_to_symbol_table (Yes dcl_mod) optional_predef_mod modules mod_index macro_and_fun_defs cs + # (mod_sizes_and_defs,macro_and_fun_defs,cs) = add_module_to_symbol_table dcl_mod mod_index macro_and_fun_defs cs + (mods, macro_and_fun_defs, cs) = add_predef_module_and_modules_to_symbol_table optional_predef_mod modules (inc mod_index) macro_and_fun_defs cs + = ([mod_sizes_and_defs : mods], macro_and_fun_defs, cs) + add_dcl_module_predef_module_and_modules_to_symbol_table No optional_predef_mod modules mod_index macro_and_fun_defs cs + = add_predef_module_and_modules_to_symbol_table optional_predef_mod modules mod_index macro_and_fun_defs cs + + add_predef_module_and_modules_to_symbol_table (Yes predef_mod) modules mod_index macro_and_fun_defs cs + # (mod_sizes_and_defs,macro_and_fun_defs,cs) = add_module_to_symbol_table predef_mod mod_index macro_and_fun_defs cs + (mods, macro_and_fun_defs, cs) = add_modules_to_symbol_table modules (inc mod_index) macro_and_fun_defs cs + = ([mod_sizes_and_defs : mods], macro_and_fun_defs, cs) + add_predef_module_and_modules_to_symbol_table No modules mod_index macro_and_fun_defs cs + = add_modules_to_symbol_table modules mod_index macro_and_fun_defs cs + + add_modules_to_symbol_table [] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table,cs_x} + # (cs_predef_symbols, cs_symbol_table) = (cs_predef_symbols, cs_symbol_table) + <=< adjust_predefined_module_symbol PD_StdArray + <=< adjust_predefined_module_symbol PD_StdEnum + <=< adjust_predefined_module_symbol PD_StdBool + <=< adjust_predefined_module_symbol PD_StdDynamics + <=< adjust_predefined_module_symbol PD_PredefinedModule + = ([], macro_and_fun_defs, { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table}) + where + adjust_predefined_module_symbol :: !Index !(!*PredefinedSymbols, !*SymbolTable) -> (!*PredefinedSymbols, !*SymbolTable) + adjust_predefined_module_symbol predef_index (pre_def_symbols, symbol_table) + # (mod_symb, pre_def_symbols) = pre_def_symbols![predef_index] + # (mod_entry, symbol_table) = readPtr mod_symb.pds_ident.id_info symbol_table + = case mod_entry.ste_kind of + STE_Module _ +// -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cIclModIndex, pds_def = mod_entry.ste_index }}, symbol_table) + -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cs_x.x_main_dcl_module_n, pds_def = mod_entry.ste_index }}, symbol_table) + _ + -> (pre_def_symbols, symbol_table) +/* + add_modules_to_symbol_table [mod=:{mod_defs} : mods] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table, cs_error} + # def_instances = convert_class_instances mod_defs.def_instances + mod_defs = { mod_defs & def_instances = def_instances } + sizes_and_defs = collectFunctionTypes mod_defs.def_funtypes (collectCommonfinitions mod_defs) + (macro_and_fun_defs, (sizes, defs)) = collectMacros mod_defs.def_macros macro_and_fun_defs sizes_and_defs + mod = { mod & mod_defs = mod_defs } + (cs_symbol_table, cs_error) = addDefToSymbolTable cGlobalScope mod_index mod.mod_name (STE_Module mod) cs_symbol_table cs_error + (mods, macro_and_fun_defs, cs) + = add_modules_to_symbol_table mods (inc mod_index) macro_and_fun_defs { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } + = ([(mod, sizes, defs) : mods], macro_and_fun_defs, cs) +*/ + + add_modules_to_symbol_table [mod : mods] mod_index macro_and_fun_defs cs + # (mod_sizes_and_defs,macro_and_fun_defs,cs) = add_module_to_symbol_table mod mod_index macro_and_fun_defs cs + (mods, macro_and_fun_defs, cs) = add_modules_to_symbol_table mods (inc mod_index) macro_and_fun_defs cs + = ([mod_sizes_and_defs : mods], macro_and_fun_defs, cs) + + add_module_to_symbol_table mod=:{mod_defs} mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table, cs_error} + # def_instances = convert_class_instances mod_defs.def_instances + mod_defs = { mod_defs & def_instances = def_instances } + sizes_and_defs = collectFunctionTypes mod_defs.def_funtypes (collectCommonfinitions mod_defs) + (macro_and_fun_defs, (sizes, defs)) = collectMacros mod_defs.def_macros macro_and_fun_defs sizes_and_defs + mod = { mod & mod_defs = mod_defs } + (cs_symbol_table, cs_error) = addDefToSymbolTable cGlobalScope mod_index mod.mod_name (STE_Module mod) cs_symbol_table cs_error + = ((mod,sizes,defs),macro_and_fun_defs,{ cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }) + where + convert_class_instances :: ![ParsedInstance a] -> [ClassInstance] + convert_class_instances [pi : pins] + = [ParsedInstanceToClassInstance pi {} : convert_class_instances pins] + convert_class_instances [] + = [] + + convert_class_instances :: .[ParsedInstance FunDef] Int -> (!.[FunDef],!.[ClassInstance]); + 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 + (next_fun_defs, cins) = convert_class_instances pins next_fun_index + = (ins_members ++ next_fun_defs, [ParsedInstanceToClassInstance pi { member \\ member <- member_symbols} : cins]) + convert_class_instances [] next_fun_index + = ([], []) + + determine_indexes_of_members [{fun_symb,fun_arity}:members] next_fun_index + #! (member_symbols, last_fun_index) = determine_indexes_of_members members (inc next_fun_index) + = ([{ds_ident = fun_symb, ds_index = next_fun_index, ds_arity = fun_arity} : member_symbols], last_fun_index) + determine_indexes_of_members [] next_fun_index + = ([], next_fun_index) + +replace_icl_macros_by_dcl_macros MK_Main icl_macro_index_range decls dcl_modules cs + = (decls,dcl_modules,cs) +replace_icl_macros_by_dcl_macros _ {ir_from=first_icl_macro_index,ir_to=end_icl_macro_index} decls dcl_modules cs + #! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n + # ({dcl_macros={ir_from=first_macro_n},dcl_conversions},dcl_modules) = dcl_modules![main_dcl_module_n] + | case dcl_conversions of No -> True ; _ -> False + = (decls,dcl_modules,cs) + # (Yes dcl_to_icl_table) = dcl_conversions + # macro_renumber_table = create_icl_to_dcl_index_table_for_kind dcl_to_icl_table.[cMacroDefs] + with + create_icl_to_dcl_index_table_for_kind dcl_to_icl_table + = {createArray (end_icl_macro_index-first_icl_macro_index) NoIndex & [dcl_to_icl_table.[dcl_index]-first_icl_macro_index]=dcl_index \\ dcl_index<- [0..size dcl_to_icl_table-1]} + # decls = replace_icl_macros_by_dcl_macros decls + with + replace_icl_macros_by_dcl_macros [decl=:{dcl_kind=STE_FunctionOrMacro _,dcl_index}:decls] + # icl_n=macro_renumber_table.[dcl_index-first_icl_macro_index] + # decls = replace_icl_macros_by_dcl_macros decls; + | dcl_index>=first_icl_macro_index && dcl_index<end_icl_macro_index && icl_n<>NoIndex +// && trace_tn decl.dcl_ident + = [{decl & dcl_kind=STE_FunctionOrMacro [], dcl_index=first_macro_n+icl_n} : decls] + = [decl : decls] + replace_icl_macros_by_dcl_macros [decl:decls] + # decls = replace_icl_macros_by_dcl_macros decls; + = [decl : decls] + replace_icl_macros_by_dcl_macros [] + = [] + = (decls,dcl_modules,cs) + +check_module2 :: Ident [.ImportedObject] .[Import ImportDeclaration] .ModuleKind !.IndexRange !.IndexRange !Int !Int (Optional (Module a)) [.Declaration] *{#FunDef} *{#DclModule} (CollectedDefinitions ClassInstance IndexRange) *{#.Int} *Heaps *CheckState -> (!Bool,!.IclModule,!.{#DclModule},.{!Group},!Optional {#Int},!.{#FunDef},!Int,!.Heaps,!.{#PredefinedSymbol},!.Heap SymbolTableEntry,!.File); +check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range nr_of_functions n_functions_and_macros_in_dcl_modules optional_pre_def_mod local_defs icl_functions init_dcl_modules cdefs sizes heaps cs + # (icl_sizes_without_added_dcl_defs, sizes) = memcpy sizes + (dcl_modules, local_defs, cdefs, icl_sizes, cs) + = combineDclAndIclModule mod_type init_dcl_modules local_defs cdefs sizes cs icl_common = createCommonDefinitions cdefs - heaps = { hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = { th_vars = newHeap, th_attrs = newHeap }} + (local_defs,dcl_modules,icl_common,cs) + = renumber_icl_definitions_as_dcl_definitions mod_type local_defs dcl_modules icl_common {icl_sizes.[i] \\ i<-[0..cMacroDefs-1]} cs (dcl_modules, icl_functions, heaps, cs) - = check_predefined_module pre_def_mod.mod_name dcl_modules icl_functions heaps cs + = check_predefined_module optional_pre_def_mod dcl_modules icl_functions heaps cs iinfo = { ii_modules = dcl_modules, ii_funs_and_macros = icl_functions, ii_next_num = 0, ii_deps = [] } - (iinfo, heaps, cs) = check_dcl_module iinfo heaps cs - (_, {ii_modules,ii_funs_and_macros = icl_functions}, heaps=:{hp_expression_heap}, cs) - = checkImports mod_imports iinfo heaps cs - - cs = { cs & cs_needed_modules = 0 } + (_, imported_module_numbers,{ii_modules,ii_funs_and_macros = icl_functions}, heaps, cs) = checkImports mod_imports EndModuleNumbers iinfo heaps cs + cs = { cs & cs_x.x_needed_modules = 0 } + # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n + # imported_module_numbers = add_module_n main_dcl_module_n (add_module_n 1 imported_module_numbers) +// ii_modules = print_imported_modules 0 ii_modules + (used_module_numbers,ii_modules) = compute_used_module_numbers imported_module_numbers imported_module_numbers ii_modules + # +// (nr_of_modules, (f_consequences, ii_modules, icl_functions, hp_expression_heap, cs)) +// = check_completeness_of_all_dcl_modules ii_modules icl_functions heaps.hp_expression_heap cs + + (nr_of_modules, ii_modules) = usize ii_modules + (nr_functions, icl_functions) = usize icl_functions + f_consequences = create_empty_consequences_array nr_functions + hp_expression_heap = heaps.hp_expression_heap + (dcls_explicit, dcl_modules, cs) = addImportsToSymbolTable mod_imports [] ii_modules cs - cs = addGlobalDefinitionsToSymbolTable local_defs cs + + (local_defs,dcl_modules,cs ) = replace_icl_macros_by_dcl_macros mod_type cdefs.def_macros local_defs dcl_modules cs + + cs = addGlobalDefinitionsToSymbolTable local_defs cs (dcl_modules, icl_functions, hp_expression_heap, cs) - = checkExplicitImportCompleteness (mod_name.id_name+++".icl") dcls_explicit - dcl_modules icl_functions hp_expression_heap cs + = checkExplicitImportCompleteness (mod_name.id_name+++".icl") main_dcl_module_n dcls_explicit dcl_modules icl_functions hp_expression_heap cs heaps = { heaps & hp_expression_heap=hp_expression_heap } (icl_common, dcl_modules, hp_type_heaps, hp_var_heap, cs) - = checkCommonDefinitions cIsNotADclModule cIclModIndex icl_common dcl_modules heaps.hp_type_heaps heaps.hp_var_heap cs + = checkCommonDefinitions cIsNotADclModule main_dcl_module_n icl_common dcl_modules heaps.hp_type_heaps heaps.hp_var_heap cs (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs) - = checkInstances cIclModIndex icl_common dcl_modules hp_var_heap hp_type_heaps cs + = checkInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } @@ -2718,62 +2956,71 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs ef_cons_defs = icl_common.com_cons_defs, ef_member_defs = icl_common.com_member_defs, ef_modules = dcl_modules, 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 icl_global_function_range.ir_from icl_global_function_range.ir_to icl_functions e_info heaps cs + (icl_functions, e_info, heaps, cs) = checkMacros main_dcl_module_n cdefs.def_macros icl_functions e_info heaps cs + (icl_functions, e_info, heaps, cs) = checkFunctions main_dcl_module_n 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 mod_name 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}) - = checkInstanceBodies {ir_from = first_inst_index, ir_to = nr_of_functions} icl_functions e_info heaps cs + (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error,cs_x}) + = checkInstanceBodies icl_instance_range icl_functions e_info heaps cs + + cs_symbol_table = removeDeclarationsFromSymbolTable local_defs cGlobalScope cs_symbol_table (icl_imported, dcl_modules, cs_symbol_table) = retrieveImportsFromSymbolTable mod_imports [] e_info.ef_modules cs_symbol_table + + icl_imported = {icl_import\\icl_import<-icl_imported} + | cs_error.ea_ok # {hp_var_heap,hp_type_heaps=hp_type_heaps=:{th_vars},hp_expression_heap} = heaps (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 + = collect_specialized_functions_in_dcl_module dcl_modules icl_common.com_instance_defs icl_functions nr_of_functions main_dcl_module_n hp_var_heap th_vars hp_expression_heap - icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions} + icl_instances = icl_instance_range 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 } + icl_functions = copy_instance_types instance_types (array_plus_list icl_functions spec_functions) (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 + = adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances icl_functions main_dcl_module_n cs_predef_symbols (untransformed_fun_bodies, icl_functions) = copy_bodies icl_functions + + # (cached_functions_and_macros,icl_functions) = arrayCopyBegin icl_functions n_functions_and_macros_in_dcl_modules + (pds_alias_dummy, cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun] + (groups, icl_functions, dcl_modules, var_heap, expr_heap, cs_symbol_table, cs_error) - = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex pds_alias_dummy icl_functions + = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] main_dcl_module_n pds_alias_dummy icl_functions dcl_modules var_heap expr_heap cs_symbol_table cs_error 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, com_instance_defs = class_instances } icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instances, icl_specials = icl_specials, - icl_imported_objects = mod_imported_objects, - icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit = dcls_explicit} } + icl_imported_objects = mod_imported_objects, icl_used_module_numbers = used_module_numbers, + icl_import = icl_imported } heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} - (dcl_modules, icl_mod, heaps, cs_error) - = compareDefImp icl_sizes_without_added_dcl_defs untransformed_fun_bodies dcl_modules icl_mod heaps cs_error +// (dcl_modules, icl_mod, heaps, cs_error) +// = compareDefImp icl_sizes_without_added_dcl_defs untransformed_fun_bodies main_dcl_module_n 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) + = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, cs_x.x_main_dcl_module_n, 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 } icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, - icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions}, + icl_instances = icl_instance_range, icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, - icl_imported_objects = mod_imported_objects, - 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) + icl_imported_objects = mod_imported_objects, icl_used_module_numbers = used_module_numbers, + icl_import = icl_imported } + = (False, icl_mod, dcl_modules, {}, No, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) where - check_start_rule mod_kind mod_name {ir_from, ir_to} cs=:{cs_predef_symbols,cs_symbol_table} + check_start_rule mod_kind mod_name {ir_from, ir_to} cs=:{cs_predef_symbols,cs_symbol_table,cs_x} # (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 }}} + -> { cs & cs_predef_symbols = { cs.cs_predef_symbols & [PD_Start] = { pre_symb & pds_def = ste_index, pds_module = cs_x.x_main_dcl_module_n }}} 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 }}} _ @@ -2784,76 +3031,30 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs _ -> 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 - (next_fun_defs, cins) = convert_class_instances pins next_fun_index - = (ins_members ++ next_fun_defs, [ParsedInstanceToClassInstance pi { member \\ member <- member_symbols} : cins]) - convert_class_instances [] next_fun_index - = ([], []) - - determine_indexes_of_members [{fun_symb,fun_arity}:members] next_fun_index - #! (member_symbols, last_fun_index) = determine_indexes_of_members members (inc next_fun_index) - = ([{ds_ident = fun_symb, ds_index = next_fun_index, ds_arity = fun_arity} : member_symbols], last_fun_index) - determine_indexes_of_members [] next_fun_index - = ([], next_fun_index) - - add_modules_to_symbol_table [] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table} - # (cs_predef_symbols, cs_symbol_table) = (cs_predef_symbols, cs_symbol_table) - <=< adjust_predefined_module_symbol PD_StdArray - <=< adjust_predefined_module_symbol PD_StdEnum - <=< adjust_predefined_module_symbol PD_StdBool - <=< adjust_predefined_module_symbol PD_StdDynamics - <=< adjust_predefined_module_symbol PD_PredefinedModule - = ([], macro_and_fun_defs, { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table}) - where - adjust_predefined_module_symbol :: !Index !(!*PredefinedSymbols, !*SymbolTable) -> (!*PredefinedSymbols, !*SymbolTable) - adjust_predefined_module_symbol predef_index (pre_def_symbols, symbol_table) - # (mod_symb, pre_def_symbols) = pre_def_symbols![predef_index] - # (mod_entry, symbol_table) = readPtr mod_symb.pds_ident.id_info symbol_table - = case mod_entry.ste_kind of - STE_Module _ - -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cIclModIndex, pds_def = mod_entry.ste_index }}, symbol_table) - _ - -> (pre_def_symbols, symbol_table) - - add_modules_to_symbol_table [mod=:{mod_defs} : mods] mod_index macro_and_fun_defs cs=:{cs_predef_symbols,cs_symbol_table, cs_error} - # def_instances = convert_class_instances mod_defs.def_instances - mod_defs = { mod_defs & def_instances = def_instances } - sizes_and_defs = collectFunctionTypes mod_defs.def_funtypes (collectCommonfinitions mod_defs) - (macro_and_fun_defs, (sizes, defs)) = collectMacros mod_defs.def_macros macro_and_fun_defs sizes_and_defs - mod = { mod & mod_defs = mod_defs } - (cs_symbol_table, cs_error) = addDefToSymbolTable cGlobalScope mod_index mod.mod_name (STE_Module mod) cs_symbol_table cs_error - (mods, macro_and_fun_defs, cs) - = add_modules_to_symbol_table mods (inc mod_index) macro_and_fun_defs { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } - = ([(mod, sizes, defs) : mods], macro_and_fun_defs, cs) - where - convert_class_instances :: ![ParsedInstance a] -> [ClassInstance] - convert_class_instances [pi : pins] - = [ParsedInstanceToClassInstance pi {} : convert_class_instances pins] - convert_class_instances [] - = [] - - check_predefined_module {id_info} modules macro_and_fun_defs heaps cs=:{cs_symbol_table} + check_predefined_module (Yes {mod_name={id_info}}) modules macro_and_fun_defs heaps cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # cs = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, { entry & ste_kind = STE_ClosedModule })} {ste_kind = STE_Module mod, ste_index} = entry (modules, macro_and_fun_defs, heaps, cs) = checkDclModule False mod ste_index modules macro_and_fun_defs heaps cs - ({dcl_declared={dcls_import,dcls_local}}, modules) = modules![ste_index] - = (modules, macro_and_fun_defs, heaps, addDeclaredSymbolsToSymbolTable cIsADclModule ste_index dcls_local dcls_import cs) - - check_dcl_module iinfo=:{ii_modules} heaps cs=:{cs_symbol_table} - # (dcl_mod, ii_modules) = ii_modules![cIclModIndex] + ({dcl_declared={dcls_import,dcls_local,dcls_local_for_import}}, modules) = modules![ste_index] +// = (modules, macro_and_fun_defs, heaps, addDeclaredSymbolsToSymbolTable cIsADclModule ste_index dcls_local dcls_import cs) + = (modules, macro_and_fun_defs, heaps, addDeclaredSymbolsToSymbolTable2 cIsADclModule ste_index dcls_local_for_import dcls_import cs) + check_predefined_module No modules macro_and_fun_defs heaps cs + = (modules, macro_and_fun_defs, heaps, cs) + + check_dcl_module :: *ImportInfo *Heaps *CheckState -> (!.ImportInfo,!.Heaps,!.CheckState); + check_dcl_module iinfo=:{ii_modules} heaps cs=:{cs_symbol_table,cs_x} + # (dcl_mod, ii_modules) = ii_modules![cs_x.x_main_dcl_module_n] # dcl_info = dcl_mod.dcl_name.id_info # (entry, cs_symbol_table) = readPtr dcl_info cs_symbol_table # (_, iinfo, heaps, cs) = checkImport dcl_info entry { iinfo & ii_modules = ii_modules } heaps { cs & cs_symbol_table = cs_symbol_table } = (iinfo, heaps, cs) - collect_specialized_functions_in_dcl_module :: !w:{# DclModule} !v:{# ClassInstance} !u:{# FunDef} !Index !*VarHeap !*TypeVarHeap !*ExpressionHeap + collect_specialized_functions_in_dcl_module :: !w:{# DclModule} !v:{# ClassInstance} !u:{# FunDef} !Index !Int !*VarHeap !*TypeVarHeap !*ExpressionHeap -> (![FunDef], !w:{# DclModule}, !v:{# ClassInstance}, !u:{# FunDef}, !Index, !(Optional {# Index}), !*VarHeap, !*TypeVarHeap, !*ExpressionHeap) - collect_specialized_functions_in_dcl_module modules icl_instances icl_functions first_free_index var_heap type_var_heap expr_heap - # (dcl_mod, modules) = modules![cIclModIndex] + collect_specialized_functions_in_dcl_module modules icl_instances icl_functions first_free_index main_dcl_module_n var_heap type_var_heap expr_heap + # (dcl_mod, modules) = modules![main_dcl_module_n] # {dcl_specials,dcl_functions,dcl_common,dcl_class_specials,dcl_conversions} = dcl_mod = case dcl_conversions of Yes conversion_table @@ -2910,7 +3111,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (app_args, expr_heap) = mapSt new_bound_var tb_args expr_heap (app_info_ptr, expr_heap) = newPtr EI_Empty expr_heap tb_rhs = App { app_symb = { symb_name = fun_symb, symb_arity = fun_arity, - symb_kind = SK_Function { glob_module = cIclModIndex, glob_object = fun_index }}, + 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_index = new_fun_index, fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = Yes fun_type, @@ -2934,11 +3135,11 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs # (inst_def, fun_defs) = fun_defs![index] = { fun_defs & [index] = { inst_def & fun_type = Yes symbol_type }} - adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances fun_defs predef_symbols + adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances fun_defs main_dcl_module_n predef_symbols # ({pds_def}, predef_symbols) = predef_symbols![PD_StdArray] - | pds_def == cIclModIndex + | pds_def == main_dcl_module_n #! nr_of_instances = size class_instances - # ({dcl_common, dcl_conversions = Yes conversion_table}, dcl_modules) = dcl_modules![cIclModIndex] + # ({dcl_common, dcl_conversions = Yes conversion_table}, dcl_modules) = dcl_modules![main_dcl_module_n] ({pds_def}, predef_symbols) = predef_symbols![PD_ArrayClass] (offset_table, _, predef_symbols) = arrayFunOffsetToPD_IndexTable dcl_common.com_member_defs predef_symbols array_class_index = conversion_table.[cClassDefs].[pds_def] @@ -2952,7 +3153,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs -> (!u:{# ClassInstance},!*{# FunDef},!v:{#PredefinedSymbol}) adjust_instance_types_of_array_functions array_class_index offset_table inst_index (class_instances, fun_defs, predef_symbols) # ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index] - | glob_module == cIclModIndex && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols + | glob_module == main_dcl_module_n && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols # fun_defs = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_defs = (class_instances, fun_defs, predef_symbols) = (class_instances, fun_defs, predef_symbols) @@ -2976,14 +3177,14 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs # new = createArray size 0 = iFoldSt (\i (dst, src=:{[i]=src_i})->({ dst & [i] = src_i }, src)) 0 size (new, src) -check_needed_modules_are_imported mod_name extension cs=:{cs_needed_modules} - # cs = case cs_needed_modules bitand cNeedStdDynamics of +check_needed_modules_are_imported mod_name extension cs=:{cs_x={x_needed_modules}} + # cs = case x_needed_modules bitand cNeedStdDynamics of 0 -> cs _ -> check_it PD_StdDynamics mod_name "" extension cs - # cs = case cs_needed_modules bitand cNeedStdArray of + # cs = case x_needed_modules bitand cNeedStdArray of 0 -> cs _ -> check_it PD_StdArray mod_name " (needed for array denotations)" extension cs - # cs = case cs_needed_modules bitand cNeedStdEnum of + # cs = case x_needed_modules bitand cNeedStdEnum of 0 -> cs _ -> check_it PD_StdEnum mod_name " (needed for [..] expressions)" extension cs = cs @@ -3036,6 +3237,65 @@ makeElemTypeOfArrayFunctionStrict st=:{st_args,st_result} me_offset offset_table st_result = { st_result & at_type = TA tuple [{ elem & at_annotation = AN_Strict } : res_array]}} = st +add_module_n n EndModuleNumbers + | n<32 + = ModuleNumbers (1<<n) EndModuleNumbers + = ModuleNumbers 0 (add_module_n (n-32) EndModuleNumbers) +add_module_n n (ModuleNumbers module_numbers rest_module_numbers) + | n<32 + = ModuleNumbers (module_numbers bitor (1<<n)) rest_module_numbers + = ModuleNumbers module_numbers (add_module_n (n-32) rest_module_numbers) + +is_empty_module_n_set EndModuleNumbers + = True; +is_empty_module_n_set (ModuleNumbers 0 module_numbers) + = is_empty_module_n_set module_numbers +is_empty_module_n_set _ + = False; + +remove_first_module_number (ModuleNumbers 0 rest_module_numbers) + # (bit_n,rest_module_numbers) = remove_first_module_number rest_module_numbers + = (bit_n+32,ModuleNumbers 0 rest_module_numbers) +remove_first_module_number (ModuleNumbers module_numbers rest_module_numbers) + # bit_n = first_one_bit module_numbers + = (bit_n,ModuleNumbers (module_numbers bitand (bitnot (1<<bit_n))) rest_module_numbers) + +first_one_bit module_numbers + | module_numbers bitand 0xff<>0 + = first_one_bit_in_byte 0 module_numbers + | module_numbers bitand 0xff00<>0 + = first_one_bit_in_byte 8 module_numbers + | module_numbers bitand 0xff0000<>0 + = first_one_bit_in_byte 16 module_numbers + = first_one_bit_in_byte 24 module_numbers + +first_one_bit_in_byte n module_numbers + | module_numbers bitand (1<<n)<>0 + = n + = first_one_bit_in_byte (n+1) module_numbers + +add_new_module_numbers EndModuleNumbers module_numbers used_module_numbers + = (module_numbers,used_module_numbers) +add_new_module_numbers (ModuleNumbers new_module_numbers new_rest_module_numbers) EndModuleNumbers EndModuleNumbers + # (rest_module_numbers,rest_used_module_numbers) = add_new_module_numbers new_rest_module_numbers EndModuleNumbers EndModuleNumbers + = (ModuleNumbers new_module_numbers rest_module_numbers,ModuleNumbers new_module_numbers rest_used_module_numbers) +add_new_module_numbers (ModuleNumbers new_module_numbers new_rest_module_numbers) EndModuleNumbers (ModuleNumbers used_module_numbers rest_used_module_numbers) + # (rest_module_numbers,rest_used_module_numbers) = add_new_module_numbers new_rest_module_numbers EndModuleNumbers rest_used_module_numbers + = (ModuleNumbers (new_module_numbers bitand (bitnot used_module_numbers)) rest_module_numbers,ModuleNumbers (used_module_numbers bitor new_module_numbers) rest_used_module_numbers) +add_new_module_numbers (ModuleNumbers new_module_numbers new_rest_module_numbers) (ModuleNumbers module_numbers rest_module_numbers) EndModuleNumbers + # (rest_module_numbers,rest_used_module_numbers) = add_new_module_numbers new_rest_module_numbers rest_module_numbers EndModuleNumbers + = (ModuleNumbers (new_module_numbers bitor module_numbers) rest_module_numbers,ModuleNumbers new_module_numbers rest_used_module_numbers) +add_new_module_numbers (ModuleNumbers new_module_numbers new_rest_module_numbers) (ModuleNumbers module_numbers rest_module_numbers) (ModuleNumbers used_module_numbers rest_used_module_numbers) + # (rest_module_numbers,rest_used_module_numbers) = add_new_module_numbers new_rest_module_numbers rest_module_numbers rest_used_module_numbers + = (ModuleNumbers (module_numbers bitor (new_module_numbers bitand (bitnot used_module_numbers))) rest_module_numbers,ModuleNumbers (used_module_numbers bitor new_module_numbers) rest_used_module_numbers) + +compute_used_module_numbers module_numbers used_numbers modules + | is_empty_module_n_set module_numbers + = (used_numbers,modules) + # (first_module_number,module_numbers) = remove_first_module_number module_numbers + # (dcl_imported_module_numbers,modules) = modules![first_module_number].dcl_imported_module_numbers + # (module_numbers,used_numbers) = add_new_module_numbers dcl_imported_module_numbers module_numbers used_numbers + = compute_used_module_numbers module_numbers used_numbers modules :: ImportInfo = { ii_modules :: !.{# DclModule} @@ -3044,17 +3304,17 @@ makeElemTypeOfArrayFunctionStrict st=:{st_args,st_result} me_offset offset_table , ii_deps :: ![SymbolPtr] } -checkImports :: ![ParsedImport] !*ImportInfo !*Heaps !*CheckState -> (!Int, !*ImportInfo, !*Heaps, !*CheckState) -checkImports [] iinfo=:{ii_modules,ii_deps} heaps cs +checkImports :: ![ParsedImport] !ModuleNumberSet !*ImportInfo !*Heaps !*CheckState -> (!Int,!ModuleNumberSet,!*ImportInfo, !*Heaps, !*CheckState) +checkImports [] imported_module_numbers iinfo=:{ii_modules} heaps cs #! mod_num = size ii_modules - = (mod_num, iinfo, heaps, cs) -checkImports [ {import_module = {id_info}}: mods ] iinfo heaps cs=:{cs_symbol_table} + = (mod_num, imported_module_numbers,iinfo, heaps, cs) +checkImports [ {import_module = {id_info}}: mods ] imported_module_numbers iinfo heaps cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # imported_module_numbers = add_module_n entry.ste_index imported_module_numbers # (min_mod_num1, iinfo, heaps, cs) = checkImport id_info entry iinfo heaps { cs & cs_symbol_table = cs_symbol_table } - (min_mod_num2, iinfo, heaps, cs) = checkImports mods iinfo heaps cs - = (min min_mod_num1 min_mod_num2, iinfo, heaps, cs) + (min_mod_num2, imported_module_numbers,iinfo, heaps, cs) = checkImports mods imported_module_numbers iinfo heaps cs + = (min min_mod_num1 min_mod_num2, imported_module_numbers,iinfo, heaps, cs) - checkImport :: SymbolPtr SymbolTableEntry *ImportInfo *Heaps *CheckState -> *(Int,*ImportInfo,*Heaps,*CheckState) checkImport module_id_info entry=:{ste_kind = STE_OpenModule mod_num _} iinfo heaps cs = (mod_num, iinfo, heaps, cs) @@ -3065,8 +3325,8 @@ checkImport module_id_info entry=:{ste_kind = STE_Module mod, ste_index} iinfo=: # entry = { entry & ste_kind = STE_OpenModule ii_next_num mod} cs = { cs & cs_symbol_table = cs_symbol_table <:= (module_id_info,entry) } iinfo = { iinfo & ii_next_num = inc ii_next_num, ii_deps = [module_id_info : ii_deps] } - (min_mod_num, iinfo, heaps, cs) = checkImports mod.mod_imports iinfo heaps cs - + (min_mod_num, imported_module_numbers,iinfo, heaps, cs) = checkImports mod.mod_imports EndModuleNumbers iinfo heaps cs + iinfo = {iinfo & ii_modules.[ste_index].dcl_imported_module_numbers=imported_module_numbers} | ii_next_num <= min_mod_num # {ii_deps,ii_modules,ii_funs_and_macros} = iinfo (ii_deps, ii_modules, ii_funs_and_macros, heaps, cs) @@ -3092,18 +3352,18 @@ checkImport module_id_info entry=:{ste_kind = STE_Module mod, ste_index} iinfo=: = (ds, modules, macro_and_fun_defs, heaps, cs) = check_component [ste_index:component] lowest_mod_info ds modules macro_and_fun_defs heaps cs - check_explicit_import_completeness mod_index (modules, macro_and_fun_defs, hp_expression_heap, cs) + check_explicit_import_completeness mod_index (modules, macro_and_fun_defs, hp_expression_heap, cs=:{cs_x}) # ({dcl_name, dcl_declared}, modules) = modules![mod_index] ({dcls_local, dcls_import, dcls_explicit}) = dcl_declared cs = addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs + dcls_explicit = [dcl_explicit \\ dcl_explicit <-:dcls_explicit] (modules, macro_and_fun_defs, hp_expression_heap, cs=:{cs_symbol_table}) - = checkExplicitImportCompleteness (dcl_name.id_name+++".dcl") dcls_explicit - modules macro_and_fun_defs hp_expression_heap cs - (_, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable [(mod_index, dcl_declared)] [] cs_symbol_table + = checkExplicitImportCompleteness (dcl_name.id_name+++".dcl") cs_x.x_main_dcl_module_n dcls_explicit modules macro_and_fun_defs hp_expression_heap cs + cs_symbol_table = removeImportsAndLocalsOfModuleFromSymbolTable dcl_declared cs.cs_symbol_table // XXX optimise by using version that does not allocate the first result value = (modules, macro_and_fun_defs, hp_expression_heap, { cs & cs_symbol_table = cs_symbol_table }) -initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_type}, sizes, all_defs) +initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_type}, sizes, all_defs) module_n # dcl_common= createCommonDefinitions mod_defs = { dcl_name = mod_name , dcl_functions = { function \\ function <- mod_defs.def_funtypes } @@ -3114,19 +3374,29 @@ initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_t , dcl_common = dcl_common , dcl_sizes = sizes , dcl_declared = - { dcls_import = [] + { + dcls_import = {} , dcls_local = all_defs - , dcls_explicit = [] + , dcls_local_for_import = {local_declaration_for_import decl module_n \\ decl<-all_defs} + , dcls_explicit = {} } , dcl_conversions = No , dcl_is_system = case mod_type of MK_System -> True _ -> False + , dcl_imported_module_numbers = EndModuleNumbers } +local_declaration_for_import decl=:{dcl_kind=STE_FunctionOrMacro _} module_n + = decl +local_declaration_for_import decl=:{dcl_kind=STE_Imported _ _} module_n + = abort "local_declaration_for_import" +local_declaration_for_import decl=:{dcl_kind} module_n + = {decl & dcl_kind = STE_Imported dcl_kind module_n} + checkDclModule :: !Bool !(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*{#DclModule} !*{#FunDef} !*Heaps !*CheckState -> (!*{#DclModule}, !*{#FunDef}, !*Heaps, !*CheckState) -checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl_functions heaps=:{hp_var_heap, hp_type_heaps} cs +checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl_functions heaps=:{hp_var_heap, hp_type_heaps,hp_expression_heap} cs # (dcl_mod, modules) = modules![mod_index] # dcl_defined = dcl_mod.dcl_declared.dcls_local dcl_common = createCommonDefinitions mod_defs @@ -3134,16 +3404,27 @@ checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl (imports, modules, cs) = collect_imported_symbols mod_imports [] modules cs cs = add_imported_symbols_to_symbol_table imports cs cs = addGlobalDefinitionsToSymbolTable dcl_defined cs - cs = { cs & cs_needed_modules = 0 } + cs = { cs & cs_x.x_needed_modules = 0 } nr_of_dcl_functions = size dcl_mod.dcl_functions - (dcl_common, modules, hp_type_heaps, hp_var_heap, cs) + + (nr_functions, icl_functions) = usize icl_functions + f_consequences = create_empty_consequences_array nr_functions +// dcls_explicit = flatten [dcls_explicit \\ (_,{dcls_explicit})<-imports] + dcls_explicit = flatten [[dcls_explicit\\dcls_explicit<-:dcls_explicit] \\ (_,{dcls_explicit})<-imports] + + #! main_dcl_module_n = cs.cs_x.x_main_dcl_module_n +// # (_,modules,icl_functions,hp_expression_heap,cs) +// = check_completeness_of_module mod_index main_dcl_module_n dcls_explicit (mod_name.id_name+++".dcl") (f_consequences, modules, icl_functions, hp_expression_heap, cs) + + # (dcl_common, modules, hp_type_heaps, hp_var_heap, cs) = checkCommonDefinitions cIsADclModule mod_index dcl_common modules hp_type_heaps hp_var_heap cs (memb_inst_defs, nr_of_dcl_functions_and_instances, rev_spec_class_inst, dcl_common, modules, hp_type_heaps, hp_var_heap, cs) = determineTypesOfInstances nr_of_dcl_functions mod_index dcl_common modules hp_type_heaps hp_var_heap cs (nr_of_dcl_funs_insts_and_specs, rev_function_list, rev_special_defs, com_type_defs, com_class_defs, modules, heaps, cs) = checkDclFunctions mod_index nr_of_dcl_functions_and_instances mod_defs.def_funtypes - dcl_common.com_type_defs dcl_common.com_class_defs modules { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } cs +// dcl_common.com_type_defs dcl_common.com_class_defs modules { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } cs + dcl_common.com_type_defs dcl_common.com_class_defs modules { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap, hp_expression_heap=hp_expression_heap} cs (nr_of_dcl_funs_insts_and_specs, new_class_instances, rev_special_defs, all_spec_types, heaps, cs_error) = checkSpecialsOfInstances mod_index nr_of_dcl_functions rev_spec_class_inst nr_of_dcl_funs_insts_and_specs [] @@ -3169,11 +3450,17 @@ checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl cs = check_needed_modules_are_imported mod_name ".dcl" cs - dcls_explicit = flatten [dcls_explicit \\ (_,{dcls_explicit})<-imports] + com_instance_defs = dcl_common.com_instance_defs + com_instance_defs = array_plus_list com_instance_defs new_class_instances + + (ef_member_defs, com_instance_defs, dcl_functions, cs) + = adjust_predefined_symbols mod_index e_info.ef_member_defs com_instance_defs dcl_functions cs + +// dcls_explicit = flatten [dcls_explicit \\ (_,{dcls_explicit})<-imports] + dcls_explicit = flatten [[dcls_explicit\\dcls_explicit<-:dcls_explicit] \\ (_,{dcls_explicit})<-imports] (modules, icl_functions, hp_expression_heap, cs) = case is_on_cycle of - False -> checkExplicitImportCompleteness (mod_name.id_name+++".dcl") dcls_explicit - modules icl_functions hp_expression_heap cs + False -> checkExplicitImportCompleteness (mod_name.id_name+++".dcl") main_dcl_module_n dcls_explicit modules icl_functions hp_expression_heap cs True -> (modules, icl_functions, hp_expression_heap, cs) heaps = { heaps & hp_expression_heap = hp_expression_heap } @@ -3184,8 +3471,14 @@ checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl com_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs } (dcl_imported, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable imports [] cs.cs_symbol_table + + dcl_imported = {dcl_import\\dcl_import<-dcl_imported} + cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs_symbol_table +// dcls_explicit = flatten [dcls_explicit \\ (_,{dcls_explicit})<-imports] + dcls_explicit = {dcls_explicit \\ dcls_explicit<-dcls_explicit} + dcl_mod = { dcl_mod & dcl_declared = { dcl_mod.dcl_declared & dcls_import = dcl_imported, dcls_explicit = dcls_explicit }, dcl_common = dcl_common, dcl_functions = dcl_functions, dcl_instances = { ir_from = nr_of_dcl_functions, ir_to = nr_of_dcl_functions_and_instances }, @@ -3207,7 +3500,7 @@ where # cs = { cs & cs_symbol_table = cs_symbol_table <:= (module_id_info, { entry & ste_kind = STE_LockedModule })} (imported_decls, modules, cs) = collect_imported_symbols mod_imports [] modules cs # (dcl_mod, modules) = modules![ste_index] - # (declared, cs) = determine_declared_symbols ste_index dcl_mod.dcl_declared.dcls_local imported_decls cs + # (declared, cs) = determine_declared_symbols ste_index dcl_mod.dcl_declared imported_decls cs = ( [(ste_index, declared) : all_decls] , modules , { cs & cs_symbol_table = cs.cs_symbol_table <:= (module_id_info, { entry & ste_kind = old_kind })} @@ -3218,14 +3511,19 @@ where collect_declarations_of_module module_id_info entry=:{ste_kind= STE_LockedModule} all_decls modules cs = (all_decls, modules, cs) - determine_declared_symbols mod_index definitions imported_decls cs - # cs = addGlobalDefinitionsToSymbolTable definitions (add_imported_symbols_to_symbol_table imported_decls cs) + determine_declared_symbols mod_index {dcls_local,dcls_local_for_import} imported_decls cs + # cs = addGlobalDefinitionsToSymbolTable dcls_local (add_imported_symbols_to_symbol_table imported_decls cs) (dcls_import, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable imported_decls [] cs.cs_symbol_table - cs_symbol_table = removeDeclarationsFromSymbolTable definitions cModuleScope cs_symbol_table - = ( {dcls_import = dcls_import, dcls_local = definitions, dcls_explicit = []}, { cs & cs_symbol_table = cs_symbol_table }) - add_imported_symbols_to_symbol_table [(mod_index, {dcls_import,dcls_local}) : imports] cs - = add_imported_symbols_to_symbol_table imports (addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs) + dcls_import = {dcl_import\\dcl_import<-dcls_import} + + cs_symbol_table = removeDeclarationsFromSymbolTable dcls_local cModuleScope cs_symbol_table + = ( {dcls_import = dcls_import, dcls_local = dcls_local, dcls_local_for_import = dcls_local_for_import, + dcls_explicit = {}}, { cs & cs_symbol_table = cs_symbol_table }) + + add_imported_symbols_to_symbol_table [(mod_index, {dcls_import,dcls_local,dcls_local_for_import}) : imports] cs +// = add_imported_symbols_to_symbol_table imports (addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs) + = add_imported_symbols_to_symbol_table imports (addDeclaredSymbolsToSymbolTable2 cIsADclModule mod_index dcls_local_for_import dcls_import cs) add_imported_symbols_to_symbol_table [] cs = cs @@ -3311,18 +3609,20 @@ where NewEntry symbol_table symb_ptr def_kind def_index level previous :== symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous }) -addImportsToSymbolTable :: ![ParsedImport] ![(!Declaration, !LineNr)] !*{# DclModule} !*CheckState - -> (![(!Declaration, !LineNr)], !*{# DclModule}, !*CheckState) -addImportsToSymbolTable [{import_module={id_info},import_symbols, import_file_position=LinePos filename line_nr} : mods ] explicit_akku modules cs=:{cs_symbol_table} - # ({ste_index}, cs_symbol_table) = readPtr id_info cs_symbol_table +//addImportsToSymbolTable :: ![ParsedImport] ![(!Declaration, !LineNr)] !*{# DclModule} !*CheckState +// -> (![(!Declaration, !LineNr)], !*{# DclModule}, !*CheckState) +addImportsToSymbolTable :: ![ParsedImport] ![ExplicitImport] !*{# DclModule} !*CheckState + -> (![ExplicitImport], !*{# DclModule}, !*CheckState) +addImportsToSymbolTable [{import_module={id_info},import_symbols, import_file_position=LinePos filename line_nr} : mods ] explicit_akku modules cs=:{cs_symbol_table} + # ({ste_index}, cs_symbol_table) = readPtr id_info cs_symbol_table # ({dcl_declared=decls_of_imported_module}, modules) = modules![ste_index] - (imported_decls, modules, cs) = possibly_filter_decls import_symbols [(ste_index, decls_of_imported_module)] (filename, line_nr) - modules { cs & cs_symbol_table = cs_symbol_table } + (imported_decls, modules, cs) + = possibly_filter_decls import_symbols [(ste_index, decls_of_imported_module)] (filename,line_nr) modules { cs & cs_symbol_table = cs_symbol_table } | isEmpty imported_decls = addImportsToSymbolTable mods explicit_akku modules cs - # (_,{dcls_import,dcls_local,dcls_explicit}) = hd imported_decls - = addImportsToSymbolTable mods (dcls_explicit++explicit_akku) - modules (addDeclaredSymbolsToSymbolTable cIsNotADclModule ste_index dcls_local dcls_import cs) + # (_,{dcls_import,dcls_local,dcls_local_for_import,dcls_explicit}) = hd imported_decls +// = addImportsToSymbolTable mods (dcls_explicit++explicit_akku) modules (addDeclaredSymbolsToSymbolTable cIsNotADclModule ste_index dcls_local dcls_import cs) + = addImportsToSymbolTable mods ([dcls_explicit\\dcls_explicit<-:dcls_explicit]++explicit_akku) modules (addDeclaredSymbolsToSymbolTable2 cIsNotADclModule ste_index dcls_local_for_import dcls_import cs) addImportsToSymbolTable [] explicit_akku modules cs = (explicit_akku, modules, cs) @@ -3386,7 +3686,8 @@ where instance <<< Declarations where - (<<<) file { dcls_import, dcls_local } = file <<< "I:" <<< dcls_import <<< "L:" <<< dcls_local +// (<<<) file { dcls_import, dcls_local } = file <<< "I:" <<< dcls_import <<< "L:" <<< dcls_local + (<<<) file { dcls_import, dcls_local } = file <<< "I:" <<< /*dcls_import <<< */ "L:" <<< dcls_local instance <<< Specials where @@ -3435,6 +3736,3 @@ where | level == entry.ste_def_level = remove_defs_from_symbol_table level (inc from_index) to_index defs (symbol_table <:= (id_info, entry.ste_previous)) = remove_defs_from_symbol_table level (inc from_index) to_index defs symbol_table - - - diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index df8b8bb..d355952 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -3,8 +3,7 @@ definition module checksupport import StdEnv import syntax, predef - -cIclModIndex :== 0 +//cIclModIndex :== 0 CS_NotChecked :== -1 NotFound :== -1 @@ -31,8 +30,9 @@ cNeedStdDynamics:== 4 :: ErrorAdmin = { ea_file :: !.File, ea_loc :: ![IdentPos], ea_ok :: !Bool } -:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin, - cs_needed_modules :: !BITVECT } // MW++ +:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin,cs_x :: !CheckStateX } + +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int } // SymbolTable :== {# SymbolTableEntry} @@ -68,22 +68,31 @@ cConversionTableSize :== 8 , dcl_index :: !Index } -:: Declarations = - { dcls_import ::![Declaration] +:: Declarations = { + dcls_import ::!{!Declaration} , dcls_local ::![Declaration] - , dcls_explicit ::![(!Declaration, !LineNr)] + , dcls_local_for_import ::!{!Declaration} + , dcls_explicit ::!{!ExplicitImport} } +:: ExplicitImport = ExplicitImport !Declaration !LineNr; + :: IclModule = { icl_name :: !Ident , icl_functions :: !.{# FunDef } , icl_instances :: !IndexRange , icl_specials :: !IndexRange , icl_common :: !.CommonDefs - , icl_declared :: !Declarations +// , icl_declared :: !Declarations + , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] + , icl_used_module_numbers :: !ModuleNumberSet } +:: ModuleNumberSet = ModuleNumbers !Int !ModuleNumberSet | EndModuleNumbers; + +in_module_number_set :: !Int !ModuleNumberSet -> Bool + :: DclModule = { dcl_name :: !Ident , dcl_functions :: !{# FunType } @@ -96,6 +105,7 @@ cConversionTableSize :== 8 , dcl_declared :: !Declarations , dcl_conversions :: !Optional ConversionTable , dcl_is_system :: !Bool + , dcl_imported_module_numbers :: !ModuleNumberSet } class Erroradmin state @@ -125,10 +135,13 @@ instance toInt STE_Kind instance <<< STE_Kind, IdentPos, Declaration retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); -retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +//retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +//retrieveAndRemoveImportsOfModuleFromSymbolTable :: !{!.Declaration} ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) -addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; +//addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; +addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] !{!.Declaration} !*CheckState -> .CheckState; +addDeclaredSymbolsToSymbolTable2 :: .Bool .Int !{!.Declaration} !{!.Declaration} !*CheckState -> .CheckState; //addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState; addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState; @@ -137,3 +150,4 @@ removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) removeDeclarationsFromSymbolTable :: ![Declaration] !Int !*(Heap SymbolTableEntry) -> *Heap SymbolTableEntry; removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; +removeImportsAndLocalsOfModuleFromSymbolTable :: !Declarations !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index bacf06b..225eb06 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -6,7 +6,7 @@ import utilities :: VarHeap :== Heap VarInfo -cIclModIndex :== 0 +//cIclModIndex :== 0 CS_NotChecked :== -1 NotFound :== -1 @@ -31,8 +31,9 @@ cNeedStdDynamics:== 4 :: ErrorAdmin = { ea_file :: !.File, ea_loc :: ![IdentPos], ea_ok :: !Bool } -:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin, - cs_needed_modules :: !BITVECT } // MW++ +:: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin, cs_x :: !CheckStateX } + +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int } :: ConversionTable :== {# .{# Int }} @@ -75,11 +76,14 @@ where , dcl_index :: !Index } -:: Declarations = - { dcls_import ::![Declaration] +:: Declarations = { + dcls_import ::!{!Declaration} , dcls_local ::![Declaration] - , dcls_explicit ::![(!Declaration, !LineNr)] + , dcls_local_for_import ::!{!Declaration} + , dcls_explicit ::!{!ExplicitImport} } + +:: ExplicitImport = ExplicitImport !Declaration !LineNr; :: IclModule = { icl_name :: !Ident @@ -87,8 +91,10 @@ where , icl_instances :: !IndexRange , icl_specials :: !IndexRange , icl_common :: !.CommonDefs - , icl_declared :: !Declarations +// , icl_declared :: !Declarations + , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] + , icl_used_module_numbers :: !ModuleNumberSet } :: DclModule = @@ -103,8 +109,19 @@ where , dcl_declared :: !Declarations , dcl_conversions :: !Optional ConversionTable , dcl_is_system :: !Bool + , dcl_imported_module_numbers :: !ModuleNumberSet } +:: ModuleNumberSet = ModuleNumbers !Int !ModuleNumberSet | EndModuleNumbers; + +in_module_number_set :: !Int !ModuleNumberSet -> Bool +in_module_number_set n EndModuleNumbers + = False; +in_module_number_set n (ModuleNumbers module_numbers rest_module_numbers) + | n<32 + = (module_numbers bitand (1<<n))<>0 + = in_module_number_set (n-32) rest_module_numbers + class Erroradmin state // PK... where pushErrorAdmin :: !IdentPos *state -> *state @@ -180,7 +197,6 @@ where envLookUp var [] = (False, abort "illegal value") - instance envLookUp ATypeVar where envLookUp var=:{atv_variable} [bind:binds] @@ -190,21 +206,26 @@ where envLookUp var [] = (False, abort "illegal value") - retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); -retrieveAndRemoveImportsFromSymbolTable [(_, {dcls_import,dcls_local}) : imports] all_decls symbol_table - # (all_decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local all_decls symbol_table +retrieveAndRemoveImportsFromSymbolTable [(_, {dcls_import,dcls_local,dcls_local_for_import}) : imports] all_decls symbol_table +// # (all_decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local all_decls symbol_table + # (all_decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable2 dcls_import dcls_local_for_import all_decls symbol_table = retrieveAndRemoveImportsFromSymbolTable imports all_decls symbol_table retrieveAndRemoveImportsFromSymbolTable [] all_decls symbol_table = (all_decls, symbol_table) - -retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); + +retrieveAndRemoveImportsOfModuleFromSymbolTable2 :: !{!.Declaration} !{!.Declaration} ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); +retrieveAndRemoveImportsOfModuleFromSymbolTable2 imports locals_for_import all_decls symbol_table + # (all_decls, symbol_table) = retrieve_declared_symbols_in_array 0 imports all_decls symbol_table + = retrieve_declared_symbols_in_array 0 locals_for_import all_decls symbol_table + +retrieveAndRemoveImportsOfModuleFromSymbolTable :: !{!.Declaration} ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_table - # (all_decls, symbol_table) = retrieve_declared_symbols imports all_decls symbol_table + # (all_decls, symbol_table) = retrieve_declared_symbols_in_array 0 imports all_decls symbol_table = retrieve_declared_symbols locals all_decls symbol_table where retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable) - retrieve_declared_symbols [symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index}:symbols] decls symbol_table + retrieve_declared_symbols [declaration=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index}:symbols] decls symbol_table #! entry = sreadPtr id_info symbol_table # {ste_kind,ste_def_level} = entry | ste_kind == STE_Empty || ste_def_level > cModuleScope @@ -215,62 +236,120 @@ where | case dcl_kind of STE_Field f -> f==selector_id _ -> False - -> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) - #! symbol = { symbol & dcl_kind = ste_kind } - -> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + -> retrieve_declared_symbols symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) STE_Imported (STE_Field selector_id) def_mod | case dcl_kind of STE_Imported (STE_Field f) d -> d==def_mod && f==selector_id _ -> False - -> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) - #! symbol = { symbol & dcl_kind = ste_kind } - -> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + -> retrieve_declared_symbols symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) _ | same_STE_Kind ste_kind dcl_kind - -> retrieve_declared_symbols symbols [symbol : decls ] symbol_table - #! symbol = { symbol & dcl_kind = ste_kind } - -> retrieve_declared_symbols symbols [symbol : decls ] symbol_table + -> retrieve_declared_symbols symbols [declaration : decls ] symbol_table + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols symbols [declaration : decls ] symbol_table retrieve_declared_symbols [] decls symbol_table = (decls, symbol_table) -/* - retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable) - retrieve_declared_symbols decls collected_decls symbol_table - = foldSt retrieve_declared_symbol decls (collected_decls, symbol_table) - retrieve_declared_symbol symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} (decls, symbol_table) +retrieve_declared_symbols_in_array :: !Int !{!Declaration} ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable) +retrieve_declared_symbols_in_array symbol_index symbols decls symbol_table + | symbol_index<size symbols + #! (declaration,symbols) = symbols![symbol_index] + # {dcl_ident=ident=:{id_info},dcl_kind}=declaration #! entry = sreadPtr id_info symbol_table -// # {ste_kind,ste_def_level,ste_previous} = entry # {ste_kind,ste_def_level} = entry | ste_kind == STE_Empty || ste_def_level > cModuleScope - = (decls, symbol_table) + = retrieve_declared_symbols_in_array (symbol_index+1) symbols decls symbol_table + # symbol_table = symbol_table <:= (id_info, entry.ste_previous) = case ste_kind of STE_Field selector_id -// -> ([{ symbol & dcl_kind = ste_kind } : decls ], -// removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, ste_previous))) - #! symbol = { symbol & dcl_kind = ste_kind } - -> ([symbol : decls ], - removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, entry.ste_previous))) + | case dcl_kind of + STE_Field f -> f==selector_id + _ -> False + #! (declaration,symbols) = symbols![symbol_index] + #! dcl_index = symbols.[symbol_index].dcl_index + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + #! (declaration,symbols) = symbols![symbol_index] + #! dcl_index = declaration.dcl_index + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) STE_Imported (STE_Field selector_id) def_mod -// -> ([{ symbol & dcl_kind = ste_kind } : decls ], -// removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, ste_previous))) - #! symbol = { symbol & dcl_kind = ste_kind } - -> ([symbol : decls ], - removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, entry.ste_previous))) + | case dcl_kind of + STE_Imported (STE_Field f) d -> d==def_mod && f==selector_id + _ -> False + #! (declaration,symbols) = symbols![symbol_index] + #! dcl_index = symbols.[symbol_index].dcl_index + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + #! (declaration,symbols) = symbols![symbol_index] + #! dcl_index = declaration.dcl_index + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) _ -// -> ([{ symbol & dcl_kind = ste_kind } : decls ], symbol_table <:= (id_info, ste_previous)) - #! symbol = { symbol & dcl_kind = ste_kind } - -> ([symbol : decls ], symbol_table <:= (id_info, entry.ste_previous)) -*/ + | same_STE_Kind ste_kind dcl_kind + #! (declaration,symbols) = symbols![symbol_index] + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] symbol_table + #! (declaration,symbols) = symbols![symbol_index] + #! declaration = { declaration & dcl_kind = ste_kind } + -> retrieve_declared_symbols_in_array (symbol_index+1) symbols [declaration : decls ] symbol_table + = (decls, symbol_table) same_STE_Kind (STE_Imported s1 i1) (STE_Imported s2 i2) = i1==i2 && same_STE_Kind s1 s2 same_STE_Kind STE_DclFunction STE_DclFunction = True +same_STE_Kind (STE_FunctionOrMacro []) (STE_FunctionOrMacro []) = True same_STE_Kind STE_Type STE_Type = True +same_STE_Kind STE_Constructor STE_Constructor = True +same_STE_Kind (STE_Field f1) (STE_Field f2) = f1==f2 same_STE_Kind STE_Instance STE_Instance = True same_STE_Kind STE_Member STE_Member = True same_STE_Kind STE_Class STE_Class = True -same_STE_Kind (STE_Field f1) (STE_Field f2) = f1==f2 same_STE_Kind _ _ = False +removeImportsAndLocalsOfModuleFromSymbolTable :: !Declarations !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry +removeImportsAndLocalsOfModuleFromSymbolTable {dcls_import,dcls_local} symbol_table + # symbol_table = remove_declared_symbols_in_array 0 dcls_import symbol_table + = remove_declared_symbols dcls_local symbol_table +where + remove_declared_symbols :: ![Declaration] !*SymbolTable -> !*SymbolTable + remove_declared_symbols [symbol=:{dcl_ident={id_info},dcl_index}:symbols] symbol_table + #! entry = sreadPtr id_info symbol_table + # {ste_kind,ste_def_level} = entry + | ste_kind == STE_Empty || ste_def_level > cModuleScope + = remove_declared_symbols symbols symbol_table + # symbol_table = symbol_table <:= (id_info, entry.ste_previous) + = case ste_kind of + STE_Field selector_id + -> remove_declared_symbols symbols (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + STE_Imported (STE_Field selector_id) def_mod + -> remove_declared_symbols symbols (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + _ + -> remove_declared_symbols symbols symbol_table + remove_declared_symbols [] symbol_table + = symbol_table + + remove_declared_symbols_in_array :: !Int !{!Declaration} !*SymbolTable -> !*SymbolTable + remove_declared_symbols_in_array symbol_index symbols symbol_table + | symbol_index<size symbols + #! (symbol,symbols) = symbols![symbol_index] + # {dcl_ident={id_info}}=symbol + #! entry = sreadPtr id_info symbol_table + # {ste_kind,ste_def_level} = entry + | ste_kind == STE_Empty || ste_def_level > cModuleScope + = remove_declared_symbols_in_array (symbol_index+1) symbols symbol_table + # symbol_table = symbol_table <:= (id_info, entry.ste_previous) + = case ste_kind of + STE_Field selector_id + #! dcl_index = symbols.[symbol_index].dcl_index + -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + STE_Imported (STE_Field selector_id) def_mod + #! dcl_index = symbols.[symbol_index].dcl_index + -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + _ + -> remove_declared_symbols_in_array (symbol_index+1) symbols symbol_table + = symbol_table + addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addLocalFunctionDefsToSymbolTable level from_index to_index fun_defs symbol_table error | from_index == to_index @@ -291,15 +370,21 @@ addDefToSymbolTable level def_index def_ident=:{id_info} def_kind symbol_table e = (symbol_table <:= (id_info,entry), error) = (symbol_table, checkError def_ident " already defined" error) -addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; +addDeclaredSymbolsToSymbolTable2 :: .Bool .Int !{!.Declaration} !{!.Declaration} !*CheckState -> .CheckState; +addDeclaredSymbolsToSymbolTable2 is_dcl_mod ste_index locals imported cs + # cs=add_imports_in_array_to_symbol_table 0 is_dcl_mod imported cs + = addLocalSymbolsForImportToSymbolTable 0 locals ste_index cs + +addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] !{!.Declaration} !*CheckState -> .CheckState; addDeclaredSymbolsToSymbolTable is_dcl_mod ste_index locals imported cs - = addLocalSymbolsToSymbolTable locals ste_index (add_imports_to_symbol_table is_dcl_mod imported cs) + # cs=add_imports_in_array_to_symbol_table 0 is_dcl_mod imported cs + = addLocalSymbolsToSymbolTable locals ste_index cs where - add_imports_to_symbol_table is_dcl_mod [{dcl_ident,dcl_pos,dcl_kind,dcl_index} : symbols] cs + add_imports_to_symbol_table is_dcl_mod [{dcl_ident,dcl_pos,dcl_kind,dcl_index} : symbols] cs=:{cs_x} = case dcl_kind of STE_Imported def_kind def_mod - | is_dcl_mod || def_mod <> cIclModIndex -// -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedSymbol dcl_ident dcl_pos def_kind dcl_index def_mod cs) + | is_dcl_mod || def_mod <> cs_x.x_main_dcl_module_n + // -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedSymbol dcl_ident dcl_pos def_kind dcl_index def_mod cs) -> add_imports_to_symbol_table is_dcl_mod symbols (addIndirectlyImportedSymbol dcl_ident dcl_pos dcl_kind def_kind dcl_index def_mod cs) -> add_imports_to_symbol_table is_dcl_mod symbols cs STE_FunctionOrMacro _ @@ -307,13 +392,40 @@ where add_imports_to_symbol_table is_dcl_mod [] cs = cs +add_imports_in_array_to_symbol_table symbol_index is_dcl_mod symbols cs=:{cs_x} + | symbol_index<size symbols + #! ({dcl_ident,dcl_pos,dcl_kind},symbols) = symbols![symbol_index] + = case dcl_kind of + STE_Imported def_kind def_mod +// | is_dcl_mod || def_mod <> cIclModIndex + | is_dcl_mod || def_mod <> cs_x.x_main_dcl_module_n +// -> add_imports_in_array_to_symbol_table (symbol_index+1) is_dcl_mod symbols (addImportedSymbol dcl_ident dcl_pos def_kind dcl_index def_mod cs) + #! dcl_index= symbols.[symbol_index].dcl_index + -> add_imports_in_array_to_symbol_table (symbol_index+1) is_dcl_mod symbols (addIndirectlyImportedSymbol dcl_ident dcl_pos dcl_kind def_kind dcl_index def_mod cs) + -> add_imports_in_array_to_symbol_table (symbol_index+1) is_dcl_mod symbols cs + STE_FunctionOrMacro _ + #! dcl_index= symbols.[symbol_index].dcl_index + -> add_imports_in_array_to_symbol_table (symbol_index+1) is_dcl_mod symbols (addImportedFunctionOrMacro dcl_ident dcl_index cs) + = cs + +addLocalSymbolsForImportToSymbolTable :: !Int !{!.Declaration} Int !*CheckState -> .CheckState; +addLocalSymbolsForImportToSymbolTable symbol_index symbols mod_index cs + | symbol_index<size symbols + # ({dcl_ident,dcl_pos,dcl_kind,dcl_index},symbols) = symbols![symbol_index] + = case dcl_kind of + STE_FunctionOrMacro _ + -> addLocalSymbolsForImportToSymbolTable (symbol_index+1) symbols mod_index (addImportedFunctionOrMacro dcl_ident dcl_index cs) + STE_Imported def_kind def_mod + -> addLocalSymbolsForImportToSymbolTable (symbol_index+1) symbols mod_index (addIndirectlyImportedSymbol dcl_ident dcl_pos dcl_kind def_kind dcl_index mod_index cs) + = cs + addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; addLocalSymbolsToSymbolTable [{dcl_ident,dcl_pos,dcl_kind,dcl_index} : symbols] mod_index cs = case dcl_kind of STE_FunctionOrMacro _ -> addLocalSymbolsToSymbolTable symbols mod_index (addImportedFunctionOrMacro dcl_ident dcl_index cs) _ - -> addLocalSymbolsToSymbolTable symbols mod_index (addImportedSymbol dcl_ident dcl_pos dcl_kind dcl_index mod_index cs) + -> addLocalSymbolsToSymbolTable symbols mod_index (addImportedSymbol dcl_ident dcl_pos dcl_kind dcl_index mod_index cs) addLocalSymbolsToSymbolTable [] mod_index cs = cs @@ -338,7 +450,7 @@ addFieldToSelectorDefinition {id_info} glob_field_index cs=:{cs_symbol_table} -> { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { entry & ste_kind = STE_Selector [ glob_field_index : selector_list ] })} _ -> { cs & cs_symbol_table = NewEntry cs.cs_symbol_table id_info (STE_Selector [glob_field_index]) NoIndex cModuleScope entry } - + addImportedSymbol :: !Ident !Position !STE_Kind !.Int !.Int !*CheckState -> .CheckState; addImportedSymbol ident pos def_kind def_index def_mod cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table @@ -393,17 +505,18 @@ where -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = dcl_index } cs _ -> cs - = { cs & cs_error = checkErrorWithIdentPos (newPosition ident dcl_pos) "(global definition) already defined" cs.cs_error} + = { cs & cs_error = checkErrorWithIdentPos (newPosition ident dcl_pos) "(global definition) already defined" cs.cs_error} ---> entry.ste_kind retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry); retrieveImportsFromSymbolTable [{import_module=import_module=:{id_info},import_symbols} : mods ] decls modules symbol_table # ({ste_index}, symbol_table) = readPtr id_info symbol_table - ({dcl_declared={dcls_import,dcls_local}}, modules) = modules![ste_index] - (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local decls symbol_table + ({dcl_declared={dcls_import,dcls_local,dcls_local_for_import}}, modules) = modules![ste_index] +// (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local decls symbol_table + (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable2 dcls_import dcls_local_for_import decls symbol_table = retrieveImportsFromSymbolTable mods decls modules symbol_table retrieveImportsFromSymbolTable [] decls modules symbol_table = (decls, modules, symbol_table) - + removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeFieldFromSelectorDefinition {id_info} field_mod field_index symbol_table # (entry, symbol_table) = readPtr id_info symbol_table @@ -438,12 +551,10 @@ where -> symbol_table <:= (id_info, ste_previous.ste_previous) -> symbol_table <:= (id_info, ste_previous) - removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeLocalIdentsFromSymbolTable level idents symbol_table = foldSt (removeIdentFromSymbolTable level) idents symbol_table - removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeIdentFromSymbolTable level {id_name,id_info} symbol_table #! {ste_previous,ste_def_level} = sreadPtr id_info symbol_table diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index e681d85..c56865c 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -196,7 +196,11 @@ checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_cons attr_vars type_lhs [rec_cons] ts_ti_cs # (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index] # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def - (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars + + | size rt_fields<>length st_args + = abort ("checkRhsOfTypeDef "+++rt_fields.[0].fs_name.id_name+++" "+++rec_cons_def.cons_symb.id_name+++toString ds_index) + + # (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars ts.ts_selector_defs ti.ti_var_heap cs.cs_error = (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, { ti & ti_var_heap = ti_var_heap }, { cs & cs_error = cs_error})) where @@ -582,7 +586,7 @@ where = (TA_Multi, oti, cs) //JVG: added type -checkOpenAType :: Int Int DemandedAttributeKind AType *(u:OpenTypeSymbols,*OpenTypeInfo,*CheckState) -> *(!AType,!*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState)); +checkOpenAType :: Int Int DemandedAttributeKind AType !*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState) -> *(!AType,!*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState)); checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs) # (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) = ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs)) @@ -658,7 +662,11 @@ checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_typ = ({ type & at_type = arg_type --> result_type, at_attribute = new_attr }, (ots, oti, cs)) checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs) # (cons_var, _, (oti, cs)) = checkTypeVar scope DAK_None tv TA_Multi (oti, cs) +// JVG (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs) +// dak_None = DAK_None +// (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope dak_None) types (ots, oti, cs) + (new_attr, oti, cs) = newAttribute dem_attr ":@:" at_attribute oti cs = ({ type & at_type = CV cons_var :@: types, at_attribute = new_attr }, (ots, oti, cs)) checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs) @@ -673,7 +681,10 @@ checkOpenType mod_index scope dem_attr type cot_state = (at_type, cot_state) checkOpenATypes mod_index scope types cot_state +// JVG = mapSt (checkOpenAType mod_index scope DAK_None) types cot_state +// # dak_None=DAK_None +// = mapSt (checkOpenAType mod_index scope dak_None) types cot_state checkInstanceType :: !Index !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState -> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) diff --git a/frontend/comparedefimp.dcl b/frontend/comparedefimp.dcl index 5750f6e..bf3ddae 100644 --- a/frontend/comparedefimp.dcl +++ b/frontend/comparedefimp.dcl @@ -4,6 +4,6 @@ import syntax, checksupport // compare definition and implementation module -compareDefImp :: !{#Int} !{!FunctionBody} !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin +compareDefImp :: !{#Int} !{!FunctionBody} !Int !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin -> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 46ce20c..1aa0d69 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -35,6 +35,8 @@ import RWSDebug :: !Conversions , tc_visited_syn_types // to detect cycles in type synonyms :: !.{#Bool} + , tc_main_dcl_module_n + :: !Int } :: TypesCorrespondMonad @@ -84,12 +86,13 @@ class CorrespondenceNumber a where initial_hwn hwn_heap = { hwn_heap = hwn_heap, hwn_number = 0 } -compareDefImp :: !{#Int} !{!FunctionBody} !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin +compareDefImp :: !{#Int} !{!FunctionBody} !Int !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin -> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin) -compareDefImp size_uncopied_icl_defs untransformed dcl_modules icl_module heaps error_admin +compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n dcl_modules icl_module heaps error_admin // icl definitions with indices >= size_uncopied_icl_defs.[def_type] don't have to be compared, // because they are copies of definitions that appear exclusively in the dcl module - # (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex] +// # (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex] + # (main_dcl_module, dcl_modules) = dcl_modules![main_dcl_module_n] = case main_dcl_module.dcl_conversions of No -> (dcl_modules, icl_module, heaps, error_admin) Yes conversion_table @@ -110,6 +113,7 @@ compareDefImp size_uncopied_icl_defs untransformed dcl_modules icl_module heaps , tc_icl_type_defs = icl_type_defs , tc_type_conversions = conversion_table.[cTypeDefs] , tc_visited_syn_types = createArray (size dcl_common.com_type_defs) False + , tc_main_dcl_module_n = main_dcl_module_n } (icl_com_type_defs, tc_state, error_admin) = compareWithConversions @@ -474,7 +478,8 @@ instance t_corresponds AType where corresponds_with_expanded_syn_type {glob_module, glob_object} dclArgs icl_atype tc_state - # is_defined_in_main_dcl = glob_module==cIclModIndex +// # is_defined_in_main_dcl = glob_module==cIclModIndex + # is_defined_in_main_dcl = glob_module==tc_state.tc_main_dcl_module_n | is_defined_in_main_dcl && tc_state.tc_visited_syn_types.[glob_object] = (False, tc_state) // cycle in synonym types in main dcl # ({dcl_common}, tc_state) = tc_state!tc_dcl_modules.[glob_module] @@ -959,7 +964,9 @@ continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app ec_state | dcl_glob_index==icl_glob_index = ec_state - | dcl_glob_index.glob_module<>cIclModIndex || icl_glob_index.glob_module<>cIclModIndex +// | dcl_glob_index.glob_module<>cIclModIndex || icl_glob_index.glob_module<>cIclModIndex + #! main_dcl_module_n=ec_state.ec_tc_state.tc_main_dcl_module_n + | dcl_glob_index.glob_module<>main_dcl_module_n || icl_glob_index.glob_module<>main_dcl_module_n = give_error icl_app_symb.symb_name ec_state // two different functions from the main module were referenced. Check their correspondence # dcl_index = dcl_glob_index.glob_object diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl index ed8071b..c87f335 100644 --- a/frontend/convertDynamics.dcl +++ b/frontend/convertDynamics.dcl @@ -3,7 +3,7 @@ definition module convertDynamics import syntax, transform, convertcases -convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) /* diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index b02a1f7..3360b59 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -34,9 +34,9 @@ import syntax, transform, utilities, convertcases :: IndirectionVar :== BoundVar -convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) -convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs groups fun_defs predefined_symbols var_heap type_heaps expr_heap +convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap #! nr_of_funs = size fun_defs # imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs } # (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions})) @@ -47,7 +47,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs groups fu ci_used_tcs = [] }) (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) - = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions groups imported_types [] type_heaps ci_var_heap + = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap = (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap) where convert_groups group_nr groups global_type_instances fun_defs_and_ci diff --git a/frontend/convertcases.dcl b/frontend/convertcases.dcl index 7f1e9ff..ef73041 100644 --- a/frontend/convertcases.dcl +++ b/frontend/convertcases.dcl @@ -4,17 +4,17 @@ import syntax, transform, trans :: ImportedFunctions :== [Global Index] -convertCasesOfFunctionsIntoPatterns :: !*{! Group} !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} +convertCasesOfFunctionsIntoPatterns :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap -> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) -convertImportedTypeSpecifications :: !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions +convertImportedTypeSpecifications :: !Int !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions !*{# {#CheckedTypeDef}} !*TypeHeaps !*VarHeap -> (!*{#{#CheckedTypeDef}}, !*TypeHeaps, !*VarHeap) -convertDclModule :: !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps +convertDclModule :: !Int !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) -convertIclModule :: !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps +convertIclModule :: !Int !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) @@ -29,6 +29,6 @@ newFunction :: !(Optional Ident) !FunctionBody ![FreeVar] ![AType] !AType !Int ! copyExpression :: ![TypedVariable] !Expression !*VarHeap -> (![Expression], ![TypedVariable], ![FreeVar], !Expression, !*VarHeap) -addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap +addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 65b9647..9b6df9d 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -461,9 +461,9 @@ toOptionalFreeVar No var_heap :: ImportedFunctions :== [Global Index] -addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap +addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) -addNewFunctionsToGroups common_defs fun_heap new_functions groups imported_types imported_conses type_heaps var_heap +addNewFunctionsToGroups common_defs fun_heap new_functions main_dcl_module_n groups imported_types imported_conses type_heaps var_heap = foldSt (add_new_function_to_group fun_heap common_defs) new_functions (groups, [], imported_types, imported_conses, type_heaps, var_heap) where @@ -474,21 +474,21 @@ where # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap group_index = gf_fun_def.fun_info.fi_group_index (Yes ft) = gf_fun_def.fun_type - (ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft imported_types imported_conses type_heaps var_heap + (ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft main_dcl_module_n imported_types imported_conses type_heaps var_heap # (group, groups) = groups![group_index] = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, [ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap) -convertCasesOfFunctionsIntoPatterns :: !*{! Group} !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} +convertCasesOfFunctionsIntoPatterns :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap -> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) -convertCasesOfFunctionsIntoPatterns groups dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap +convertCasesOfFunctionsIntoPatterns groups main_dcl_module_n dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap #! nr_of_funs = size fun_defs # (groups, (fun_defs, collected_imports, {ci_new_functions, ci_var_heap, ci_expr_heap, ci_fun_heap})) = convert_groups 0 groups dcl_functions common_defs (fun_defs, [], { ci_new_functions = [], ci_fun_heap = newHeap, ci_var_heap = var_heap, ci_expr_heap = expr_heap, ci_next_fun_nr = nr_of_funs }) (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) - = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions groups imported_types imported_conses type_heaps ci_var_heap + = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types imported_conses type_heaps ci_var_heap // = foldSt (add_new_function_to_group ci_fun_heap common_defs) ci_new_functions (groups, [], imported_types, imported_conses, type_heaps, ci_var_heap) (imported_functions, imported_conses) = foldSt split collected_imports ([], imported_conses) = (imported_functions, groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, @@ -531,7 +531,7 @@ where eliminate_code_sharing_in_function dcl_functions common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, ci=:{ci_expr_heap,ci_var_heap}) # {rc_var_heap, rc_expr_heap, rc_imports} = weightedRefCount dcl_functions common_defs 1 tb_rhs - { rc_var_heap = ci_var_heap, rc_expr_heap = ci_expr_heap, rc_free_vars = [], rc_imports = collected_imports} + { rc_var_heap = ci_var_heap, rc_expr_heap = ci_expr_heap, rc_free_vars = [], rc_imports = collected_imports,rc_main_dcl_module_n=main_dcl_module_n} // ---> ("eliminate_code_sharing_in_function (weightedRefCount)", tb_rhs) (tb_rhs, {di_lets,di_var_heap,di_expr_heap}) = distributeLets 1 tb_rhs { di_lets = [], di_var_heap = rc_var_heap, di_expr_heap = rc_expr_heap} (tb_rhs, (var_heap, expr_heap)) = buildLetExpr di_lets tb_rhs (di_var_heap,di_expr_heap) @@ -543,19 +543,19 @@ where split (SK_Constructor cons_symb) (collected_functions, collected_conses) = (collected_functions, [ cons_symb : collected_conses]) -convertDclModule :: !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps +convertDclModule :: !Int !{# DclModule} !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) -convertDclModule dcl_mods common_defs imported_types imported_conses var_heap type_heaps - # {dcl_functions,dcl_common=dcl_common=:{com_type_defs,com_cons_defs,com_selector_defs},dcl_conversions} = dcl_mods.[cIclModIndex] +convertDclModule main_dcl_module_n dcl_mods common_defs imported_types imported_conses var_heap type_heaps + # {dcl_functions,dcl_common=dcl_common=:{com_type_defs,com_cons_defs,com_selector_defs},dcl_conversions} = dcl_mods.[main_dcl_module_n] = case dcl_conversions of Yes conversion_table - # (icl_type_defs, imported_types) = imported_types![cIclModIndex] + # (icl_type_defs, imported_types) = imported_types![main_dcl_module_n] common_defs = { common \\ common <-: common_defs } - common_defs = { common_defs & [cIclModIndex] = dcl_common } - types_and_heaps = convert_dcl_functions dcl_functions common_defs ( { imported_types & [cIclModIndex] = com_type_defs }, imported_conses, var_heap, type_heaps) - types_and_heaps = convertConstructorTypes com_cons_defs common_defs types_and_heaps - (imported_types, imported_conses, var_heap, type_heaps) = convertSelectorTypes com_selector_defs common_defs types_and_heaps - -> ({ imported_types & [cIclModIndex] = icl_type_defs}, imported_conses, var_heap, type_heaps) + common_defs = { common_defs & [main_dcl_module_n] = dcl_common } + types_and_heaps = convert_dcl_functions dcl_functions common_defs ( { imported_types & [main_dcl_module_n] = com_type_defs }, imported_conses, var_heap, type_heaps) + types_and_heaps = convertConstructorTypes com_cons_defs main_dcl_module_n common_defs types_and_heaps + (imported_types, imported_conses, var_heap, type_heaps) = convertSelectorTypes com_selector_defs main_dcl_module_n common_defs types_and_heaps + -> ({ imported_types & [main_dcl_module_n] = icl_type_defs}, imported_conses, var_heap, type_heaps) No -> (imported_types, imported_conses, var_heap, type_heaps) where @@ -564,49 +564,50 @@ where convert_dcl_function dcl_functions common_defs dcl_index (imported_types, imported_conses, var_heap, type_heaps) # {ft_type, ft_type_ptr} = dcl_functions.[dcl_index] - (ft_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft_type imported_types imported_conses type_heaps var_heap + (ft_type, imported_types, imported_conses, type_heaps, var_heap) + = convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type), type_heaps) -convertConstructorTypes cons_defs common_defs types_and_heaps +convertConstructorTypes cons_defs main_dcl_module_n common_defs types_and_heaps = iFoldSt (convert_constructor_type common_defs cons_defs) 0 (size cons_defs) types_and_heaps where convert_constructor_type common_defs cons_defs cons_index (imported_types, imported_conses, var_heap, type_heaps) # {cons_type_ptr, cons_type} = cons_defs.[cons_index] (cons_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs cons_type imported_types imported_conses type_heaps var_heap + = convertSymbolType common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type), type_heaps) -convertSelectorTypes selector_defs common_defs types_and_heaps +convertSelectorTypes selector_defs main_dcl_module_n common_defs types_and_heaps = iFoldSt (convert_selector_type common_defs selector_defs) 0 (size selector_defs) types_and_heaps where convert_selector_type common_defs selector_defs sel_index (imported_types, imported_conses, var_heap, type_heaps) # {sd_type_ptr, sd_type} = selector_defs.[sel_index] (sd_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs sd_type imported_types imported_conses type_heaps var_heap + = convertSymbolType common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type), type_heaps) -convertIclModule :: !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps +convertIclModule :: !Int !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) -convertIclModule common_defs imported_types imported_conses var_heap type_heaps - # types_and_heaps = convertConstructorTypes common_defs.[cIclModIndex].com_cons_defs common_defs (imported_types, imported_conses, var_heap, type_heaps) - = convertSelectorTypes common_defs.[cIclModIndex].com_selector_defs common_defs types_and_heaps +convertIclModule main_dcl_module_n common_defs imported_types imported_conses var_heap type_heaps + # types_and_heaps = convertConstructorTypes common_defs.[main_dcl_module_n].com_cons_defs main_dcl_module_n common_defs (imported_types, imported_conses, var_heap, type_heaps) + = convertSelectorTypes common_defs.[main_dcl_module_n].com_selector_defs main_dcl_module_n common_defs types_and_heaps -convertImportedTypeSpecifications :: !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions +convertImportedTypeSpecifications :: !Int !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions !*{# {#CheckedTypeDef}} !*TypeHeaps !*VarHeap -> (!*{#{#CheckedTypeDef}}, !*TypeHeaps, !*VarHeap) -convertImportedTypeSpecifications dcl_mods dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap - # {dcl_common={com_type_defs},dcl_conversions} = dcl_mods.[cIclModIndex] +convertImportedTypeSpecifications main_dcl_module_n dcl_mods dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap + # {dcl_common={com_type_defs},dcl_conversions} = dcl_mods.[main_dcl_module_n] = case dcl_conversions of Yes conversion_table # abstract_type_indexes = iFoldSt (determine_abstract_type com_type_defs) 0 (size com_type_defs) [] | isEmpty abstract_type_indexes -> convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap - # (icl_type_defs, imported_types) = imported_types![cIclModIndex] + # (icl_type_defs, imported_types) = imported_types![main_dcl_module_n] type_defs = foldSt (insert_abstract_type conversion_table.[cTypeDefs]) abstract_type_indexes { icl_type_def \\ icl_type_def <-: icl_type_defs } (imported_types, type_heaps, var_heap) = convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions - { imported_types & [cIclModIndex] = type_defs } type_heaps var_heap - -> ({ imported_types & [cIclModIndex] = icl_type_defs }, type_heaps, var_heap) + { imported_types & [main_dcl_module_n] = type_defs } type_heaps var_heap + -> ({ imported_types & [main_dcl_module_n] = icl_type_defs }, type_heaps, var_heap) No -> convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap @@ -633,7 +634,7 @@ where convert_imported_function dcl_functions common_defs {glob_object,glob_module} (imported_types, imported_conses, type_heaps, var_heap) # {ft_type_ptr,ft_type} = dcl_functions.[glob_module].[glob_object] (ft_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs ft_type imported_types imported_conses type_heaps var_heap + = convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, type_heaps, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type)) convert_imported_constructors common_defs [] imported_types type_heaps var_heap @@ -641,7 +642,7 @@ where convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap # {com_cons_defs,com_selector_defs} = common_defs.[glob_module] {cons_type_ptr,cons_type,cons_type_index,cons_symb} = common_defs.[glob_module].com_cons_defs.[glob_object] - (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type imported_types conses type_heaps var_heap + (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type main_dcl_module_n imported_types conses type_heaps var_heap var_heap = var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type) ({td_rhs}, imported_types) = imported_types![glob_module].[cons_type_index] // ---> ("convert_imported_constructors", cons_symb, cons_type) @@ -657,7 +658,7 @@ where convert_type_of_imported_field module_index selector_defs fields field_index (imported_types, conses, type_heaps, var_heap) # field_index = fields.[field_index].fs_index {sd_type_ptr,sd_type} = selector_defs.[field_index] - (sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs sd_type imported_types conses type_heaps var_heap + (sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs sd_type main_dcl_module_n imported_types conses type_heaps var_heap = (imported_types, conses, type_heaps, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type)) convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap} @@ -966,6 +967,7 @@ where , rc_imports :: ![SymbKind] , rc_var_heap :: !.VarHeap , rc_expr_heap :: !.ExpressionHeap + , rc_main_dcl_module_n :: !Int } @@ -1083,7 +1085,7 @@ addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (fre -> (free_vars, var_heap) weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseType case_type) - rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports } + rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports,rc_main_dcl_module_n } # (local_vars, vars_and_heaps) = weighted_ref_count_in_case_patterns dcl_functions common_defs (inc depth) case_guards rc_imports rc_var_heap rc_expr_heap (default_vars, (all_vars, rc_imports, var_heap, expr_heap)) = weighted_ref_count_in_default dcl_functions common_defs (inc depth) case_default vars_and_heaps rc_info = weightedRefCount dcl_functions common_defs depth case_expr { rc_info & rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_imports = rc_imports } @@ -1094,7 +1096,7 @@ weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, ca // ---> ("weightedRefCountOfCase", ptrToInt case_info_ptr, case_expr) where weighted_ref_count_in_default dcl_functions common_defs depth (Yes expr) info - = weightedRefCountInPatternExpr dcl_functions common_defs depth expr info + = weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth expr info weighted_ref_count_in_default dcl_functions common_defs depth No info = ([], info) @@ -1103,8 +1105,9 @@ weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, ca where weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth {ap_expr,ap_symbol={glob_module, glob_object={ds_index}}} wrc_state # (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap)) - = weightedRefCountInPatternExpr dcl_functions common_defs depth ap_expr wrc_state - | glob_module <> cIclModIndex + = weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth ap_expr wrc_state +// | glob_module <> cIclModIndex + | glob_module <> rc_main_dcl_module_n # {cons_type_ptr} = common_defs.[glob_module].com_cons_defs.[ds_index] (collected_imports, var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index}) cons_type_ptr (collected_imports, var_heap) @@ -1112,9 +1115,9 @@ weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, ca = (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap)) weighted_ref_count_in_case_patterns dcl_functions common_defs depth (BasicPatterns type patterns) collected_imports var_heap expr_heap - = mapSt (\{bp_expr} -> weightedRefCountInPatternExpr dcl_functions common_defs depth bp_expr) patterns ([], collected_imports, var_heap, expr_heap) + = mapSt (\{bp_expr} -> weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth bp_expr) patterns ([], collected_imports, var_heap, expr_heap) weighted_ref_count_in_case_patterns dcl_functions common_defs depth (DynamicPatterns patterns) collected_imports var_heap expr_heap - = mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr dcl_functions common_defs depth dp_rhs) patterns ([], collected_imports, var_heap, expr_heap) + = mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth dp_rhs) patterns ([], collected_imports, var_heap, expr_heap) weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseTypeAndRefCounts case_type {rcc_all_variables}) rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports } @@ -1124,7 +1127,8 @@ weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, ca // ---> ("weightedRefCountOfCase 2", ptrToInt case_info_ptr, case_expr) checkRecordSelector common_defs {glob_module, glob_object={ds_index}} rc_info=:{rc_imports,rc_var_heap} - | glob_module <> cIclModIndex +// | glob_module <> cIclModIndex + | glob_module <> rc_info.rc_main_dcl_module_n # {com_selector_defs,com_cons_defs,com_type_defs} = common_defs.[glob_module] {sd_type_index} = com_selector_defs.[ds_index] {td_rhs = RecordType {rt_constructor={ds_index=cons_index}, rt_fields}} = com_type_defs.[sd_type_index] @@ -1145,9 +1149,9 @@ where weightedRefCount dcl_functions common_defs depth (RecordSelection selector _) rc_info = checkRecordSelector common_defs selector rc_info -weightedRefCountInPatternExpr dcl_functions common_defs depth pattern_expr (previous_free_vars, collected_imports, var_heap, expr_heap) +weightedRefCountInPatternExpr main_dcl_module_n dcl_functions common_defs depth pattern_expr (previous_free_vars, collected_imports, var_heap, expr_heap) # {rc_free_vars,rc_var_heap,rc_imports,rc_expr_heap} = weightedRefCount dcl_functions common_defs depth pattern_expr - { rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_free_vars = [], rc_imports = collected_imports} + { rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_free_vars = [], rc_imports = collected_imports,rc_main_dcl_module_n=main_dcl_module_n} (free_vars_with_rc, rc_var_heap) = mapSt get_ref_count rc_free_vars rc_var_heap (previous_free_vars, rc_var_heap) = foldSt (select_unused_free_variable depth) previous_free_vars ([], rc_var_heap) (all_free_vars, rc_var_heap) = foldSt (collect_free_variable depth) rc_free_vars (previous_free_vars, rc_var_heap) @@ -1184,7 +1188,8 @@ where */ checkImportOfDclFunction dcl_functions common_defs mod_index fun_index rc_info=:{rc_imports, rc_var_heap} - | mod_index <> cIclModIndex +// | mod_index <> cIclModIndex + | mod_index <> rc_info.rc_main_dcl_module_n # {ft_type_ptr} = dcl_functions.[mod_index].[fun_index] (rc_imports, rc_var_heap) = checkImportedSymbol (SK_Function {glob_module=mod_index,glob_object=fun_index}) ft_type_ptr (rc_imports, rc_var_heap) = { rc_info & rc_imports = rc_imports, rc_var_heap = rc_var_heap } @@ -1199,7 +1204,8 @@ where check_import dcl_functions common_defs {symb_kind=SK_Function {glob_module,glob_object}} rc_info=:{rc_imports, rc_var_heap} = checkImportOfDclFunction dcl_functions common_defs glob_module glob_object rc_info check_import dcl_functions common_defs {symb_name,symb_kind=symb_kind=:(SK_Constructor {glob_module,glob_object})} rc_info=:{rc_imports, rc_var_heap} - | glob_module <> cIclModIndex +// | glob_module <> cIclModIndex + | glob_module <> rc_info.rc_main_dcl_module_n # {cons_type_ptr} = common_defs.[glob_module].com_cons_defs.[glob_object] (rc_imports, rc_var_heap) = checkImportedSymbol symb_kind cons_type_ptr (rc_imports, rc_var_heap) = { rc_info & rc_imports = rc_imports, rc_var_heap = rc_var_heap } diff --git a/frontend/explicitimports.dcl b/frontend/explicitimports.dcl index 15e346d..5d0f037 100644 --- a/frontend/explicitimports.dcl +++ b/frontend/explicitimports.dcl @@ -8,8 +8,19 @@ temporary_import_solution_XXX yes no :== yes // This feature will be removed, when all programs are ported to Clean 2.0. The last Constructors of AtomType // and StructureType should then be removed also -possibly_filter_decls :: ![ImportDeclaration] ![(!Index,!Declarations)] !(!FileName,!LineNr) !*{#DclModule} !*CheckState - -> (![(!Index,!Declarations)],!.{#DclModule},!.CheckState) -checkExplicitImportCompleteness :: !String ![(!Declaration,!Int)] - !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState - -> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState) +//:: FunctionConsequence + +possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v]; +//possibly_filter_decls :: ![ImportDeclaration] ![(Index,Declarations)] !(!FileName,!LineNr) !*{#DclModule} !*CheckState -> (![(Index,Declarations)],!.{#DclModule},!.CheckState) + +//check_completeness_of_module :: .Index !Int [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); +/* +check_completeness_of_module :: .Index !Int [ExplicitImport] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); +check_completeness_of_all_dcl_modules :: !Int !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState + -> (!Int, !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap, !*CheckState)) + +create_empty_consequences_array :: !Int -> *{!FunctionConsequence} +*/ +//checkExplicitImportCompleteness :: !String ![(!Declaration,!Int)] !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState -> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState) +checkExplicitImportCompleteness :: !String !Int ![ExplicitImport] !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState -> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState) + diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 4487bf8..bcc6b0e 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -30,9 +30,7 @@ do_temporary_import_solution_XXX :== temporary_import_solution_XXX True False :: OptimizeInfo :== Optional Index -// XXX change !(!FileName,!LineNr) into Position -possibly_filter_decls :: ![ImportDeclaration] ![(!Index,!Declarations)] !(!FileName,!LineNr) !*{#DclModule} !*CheckState - -> (![(!Index,!Declarations)],!.{#DclModule},!.CheckState) +possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v]; possibly_filter_decls [] decls_of_imported_module _ modules cs // implicit import can't go wrong = (decls_of_imported_module, modules, cs) possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs @@ -55,21 +53,34 @@ filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,d structures = flatten (map toStructure import_symbols) (checked_atoms, cs) = checkAtoms atoms cs unimported = (checked_atoms, structures) - ((dcls_import,unimported), modules, cs) - = filter_decl dcls_import unimported undefined modules cs + + (dcls_import,unimported, modules, cs) = filter_decl_array 0 dcls_import unimported undefined modules cs + ((dcls_local,unimported), modules, cs) = filter_decl dcls_local unimported index modules cs cs_error = foldSt checkAtomError (fst unimported) cs.cs_error cs_error = foldSt checkStructureError (snd unimported) cs_error cs = { cs & cs_error=cs_error } - | (isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit) + | isEmpty dcls_import && isEmpty dcls_local && size dcls_explicit==0 = filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs - # local_imports = [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index } - \\ declaration <- dcls_local] - new_dcls_explicit = [ (dcls, line_nr) \\ dcls<-dcls_import++local_imports ] - newAkku = [(index, { dcls_import=dcls_import, dcls_local=dcls_local , dcls_explicit=new_dcls_explicit}) : akku] + # local_imports = [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index } \\ declaration <- dcls_local] + new_dcls_explicit = [ ExplicitImport dcls line_nr \\ dcls<-dcls_import++local_imports ] + + dcls_import = {dcls_import\\dcls_import<-dcls_import} + + newAkku = [(index, { dcls_import=dcls_import, dcls_local=dcls_local , + dcls_local_for_import = {local_declaration_for_import decl index \\ decl<-dcls_local}, +// dcls_explicit=new_dcls_explicit}) : akku] + dcls_explicit={new_dcls_explicit\\new_dcls_explicit<-new_dcls_explicit}}) : akku] = filter_explicitly_imported_decl import_symbols new_decls newAkku line_nr modules cs where + local_declaration_for_import decl=:{dcl_kind=STE_FunctionOrMacro _} module_n + = decl + local_declaration_for_import decl=:{dcl_kind=STE_Imported _ _} module_n + = abort "local_declaration_for_import" + local_declaration_for_import decl=:{dcl_kind} module_n + = {decl & dcl_kind = STE_Imported dcl_kind module_n} + toAtom (ID_Function {ii_ident}) = [(ii_ident, temporary_import_solution_XXX (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen False) @@ -116,16 +127,16 @@ filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,d checkAtoms l cs # groups = grouped l - wrong = filter isErrornous groups + wrong = filter isErroneous groups unique = map hd groups | isEmpty wrong = (unique, cs) = (unique, foldSt error wrong cs) where - isErrornous l=:[(_,AT_Type),_:_] = True - isErrornous l=:[(_,AT_AlgType),_:_] = True - isErrornous l=:[(_,AT_RecordType),_:_] = True - isErrornous _ = False + isErroneous l=:[(_,AT_Type),_:_] = True + isErroneous l=:[(_,AT_AlgType),_:_] = True + isErroneous l=:[(_,AT_RecordType),_:_] = True + isErroneous _ = False error [(ident, atomType):_] cs = { cs & cs_error = checkError ("type "+++ident.id_name) "imported more than once in one from statement" @@ -210,6 +221,17 @@ filter_decl [decl:decls] unimported index modules cs = (([decl:recurs],unimported), modules, cs) = filter_decl decls unimported index modules cs + +filter_decl_array :: !Int {!.Declaration} ([(Ident,AtomType)],[(Ident,StructureInfo,StructureType,Optional Int)]) Int *{#DclModule} *CheckState -> (!.[Declaration],!([(Ident,AtomType)],![(Ident,StructureInfo,StructureType,Optional Int)]),!.{#DclModule},!.CheckState); +filter_decl_array decl_index decls unimported index modules cs + | decl_index<size decls + # (decl,decls) = decls![decl_index] + # ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs + | appears + # (recurs, unimported, modules, cs) = filter_decl_array (decl_index+1) decls unimported index modules cs + = ([decl:recurs],unimported, modules, cs) + = filter_decl_array (decl_index+1) decls unimported index modules cs + = ([], unimported, modules, cs) decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState -> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState) @@ -255,7 +277,6 @@ decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs isAtom STE_Type = True isAtom STE_Instance = True - elementAppears :: .StructureType Ident !.Int !(.a,![(Ident,.StructureInfo,.StructureType,Optional .Int)]) !.Int !*{#.DclModule} !*CheckState -> (!(!Bool,(!.a,![(Ident,StructureInfo,StructureType,Optional Int)])),!.{#DclModule},!.CheckState); elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs # ((result, structureImports), modules, cs) @@ -516,19 +537,21 @@ element_appears_in_struct imported_st element_ident dcl_index struct_ident index , ccs_error :: !.ErrorAdmin , ccs_heap_changes_accu :: ![SymbolPtr] } + :: *CheckCompletenessStateBox = { box_ccs :: !*CheckCompletenessState } :: CheckCompletenessInput = { cci_line_nr :: !Int , cci_filename :: !String , cci_expl_imported_ident :: !Ident + , cci_main_dcl_module_n::!Int } + :: CheckCompletenessInputBox = { box_cci :: !CheckCompletenessInput } -checkExplicitImportCompleteness :: !String ![(!Declaration,!Int)] - !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState - -> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState) -checkExplicitImportCompleteness filename dcls_explicit dcl_modules icl_functions expr_heap +checkExplicitImportCompleteness :: !String !Int ![ExplicitImport] !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState + -> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState) +checkExplicitImportCompleteness filename main_dcl_module_n dcls_explicit dcl_modules icl_functions expr_heap cs=:{cs_symbol_table, cs_error} #! nr_icl_functions = size icl_functions box_ccs = { ccs_dcl_modules = dcl_modules, ccs_icl_functions = icl_functions, @@ -543,15 +566,15 @@ checkExplicitImportCompleteness filename dcls_explicit dcl_modules icl_functions cs = { cs & cs_symbol_table = ccs_symbol_table, cs_error = ccs_error } = (ccs_dcl_modules, ccs_icl_functions, ccs_expr_heap, cs) where - checkCompleteness :: !String !(!Declaration, !Int) *CheckCompletenessStateBox -> *CheckCompletenessStateBox - checkCompleteness filename ({dcl_ident, dcl_index, dcl_kind=STE_FunctionOrMacro _}, line_nr) ccs - = checkCompletenessOfMacro filename dcl_ident dcl_index line_nr ccs - checkCompleteness filename ({dcl_ident, dcl_index, dcl_kind=STE_Imported (STE_FunctionOrMacro _) mod_index}, line_nr) ccs - = checkCompletenessOfMacro filename dcl_ident dcl_index line_nr ccs - checkCompleteness filename ({dcl_ident, dcl_index, dcl_kind=STE_Imported expl_imp_kind mod_index}, line_nr) ccs + checkCompleteness :: !String !ExplicitImport *CheckCompletenessStateBox -> *CheckCompletenessStateBox + checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_FunctionOrMacro _} line_nr) ccs + = checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs + checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_Imported (STE_FunctionOrMacro _) mod_index} line_nr) ccs + = checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs + checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_Imported expl_imp_kind mod_index} line_nr) ccs #! ({dcl_common,dcl_functions}, ccs) = ccs!box_ccs.ccs_dcl_modules.[mod_index] - cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident }} -/* XXX + cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident,cci_main_dcl_module_n=main_dcl_module_n }} + /* XXX this case expression causes the compiler to be not self compilable anymore (12.7.2000). The bug is probably in module refmark. The corresponding continuation function can be compiled = case expl_imp_kind of @@ -562,7 +585,7 @@ checkExplicitImportCompleteness filename dcls_explicit dcl_modules icl_functions STE_Member -> check_completeness dcl_common.com_member_defs.[dcl_index] cci ccs STE_Instance -> check_completeness dcl_common.com_instance_defs.[dcl_index] cci ccs STE_DclFunction -> check_completeness dcl_functions.[dcl_index] cci ccs -*/ + */ = continuation expl_imp_kind dcl_common dcl_functions cci ccs where continuation STE_Type dcl_common dcl_functions cci ccs @@ -579,19 +602,19 @@ checkExplicitImportCompleteness filename dcls_explicit dcl_modules icl_functions = check_completeness dcl_common.com_instance_defs.[dcl_index] cci ccs continuation STE_DclFunction dcl_common dcl_functions cci ccs = check_completeness dcl_functions.[dcl_index] cci ccs - - checkCompletenessOfMacro :: !String !Ident !Index !Int *CheckCompletenessStateBox -> *CheckCompletenessStateBox - checkCompletenessOfMacro filename dcl_ident dcl_index line_nr ccs + + checkCompletenessOfMacro :: !String !Ident !Index !Int !Int *CheckCompletenessStateBox -> *CheckCompletenessStateBox + checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs #! ({fun_body}, ccs) = ccs!box_ccs.ccs_icl_functions.[dcl_index] ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[dcl_index] = True } - cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident }} + cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident,cci_main_dcl_module_n=main_dcl_module_n }} = check_completeness fun_body cci ccs replace_ste_with_previous :: !SymbolPtr !*SymbolTable -> .SymbolTable replace_ste_with_previous changed_ste_ptr symbol_table #! ({ste_previous}, symbol_table) = readPtr changed_ste_ptr symbol_table = writePtr changed_ste_ptr ste_previous symbol_table - + instance toString STE_Kind where toString (STE_FunctionOrMacro _) = "function/macro" toString STE_Type = "type" @@ -807,13 +830,15 @@ instance check_completeness SymbIdent where -> check_whether_ident_is_imported symb_name STE_Constructor cci ccs SK_Function global_index -> check_completeness_for_function symb_name global_index ste_fun_or_macro cci ccs + SK_LocalMacroFunction function_index + -> check_completeness_for_local_macro_function symb_name function_index ste_fun_or_macro cci ccs SK_OverloadedFunction global_index -> check_completeness_for_function symb_name global_index STE_Member cci ccs SK_Macro global_index -> check_completeness_for_function symb_name global_index ste_fun_or_macro cci ccs where check_completeness_for_function symb_name {glob_object,glob_module} wanted_ste_kind cci ccs - | glob_module<>cIclModIndex + | glob_module<>cci.box_cci.cci_main_dcl_module_n // the function that is referred from within a macro is a DclFunction // -> must be global -> has to be imported = check_whether_ident_is_imported symb_name wanted_ste_kind cci ccs @@ -826,6 +851,16 @@ instance check_completeness SymbIdent where #! ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[glob_object] = True } = check_completeness fun_def cci ccs + check_completeness_for_local_macro_function symb_name glob_object wanted_ste_kind cci ccs + #! (fun_def, ccs) = ccs!box_ccs.ccs_icl_functions.[glob_object] + // otherwise the function was defined locally in a macro + // it is not a consequence, but it's type and body are consequences ! + #! (already_visited, ccs) = ccs!box_ccs.ccs_set_of_visited_icl_funs.[glob_object] + | already_visited + = ccs + #! ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[glob_object] = True } + = check_completeness fun_def cci ccs + instance check_completeness SymbolType where check_completeness {st_args, st_result, st_context} cci ccs = ( (check_completeness st_args cci) diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl index 941dcdd..a8720d1 100644 --- a/frontend/frontend.dcl +++ b/frontend/frontend.dcl @@ -8,15 +8,12 @@ import checksupport, transform, overloading = { fe_icl :: !IclModule , fe_dcls :: !{#DclModule} , fe_components :: !{!Group} - , fe_varHeap :: !.VarHeap -// MdM - , fe_typeHeap :: !.TypeVarHeap -// ... MdM , fe_dclIclConversions ::!Optional {# Index} , fe_iclDclConversions ::!Optional {# Index} , fe_globalFunctions :: !IndexRange , fe_arrayInstances :: !IndexRange } + :: FrontEndPhase = FrontEndPhaseCheck | FrontEndPhaseTypeCheck @@ -25,5 +22,5 @@ import checksupport, transform, overloading | FrontEndPhaseConvertModules | FrontEndPhaseAll -frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree) -// upToPhase name paths list_inferred_types predefs files error io out
\ No newline at end of file +frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*Heaps + -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File,!*Heaps) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 98af8c2..29b61f1 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -1,16 +1,12 @@ implementation module frontend import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics -import RWSDebug +//import RWSDebug :: FrontEndSyntaxTree = { fe_icl :: !IclModule , fe_dcls :: !{#DclModule} , fe_components :: !{!Group} - , fe_varHeap :: !.VarHeap -// MdM - , fe_typeHeap :: !.TypeVarHeap -// ... MdM , fe_dclIclConversions ::!Optional {# Index} , fe_iclDclConversions ::!Optional {# Index} , fe_globalFunctions :: !IndexRange @@ -22,23 +18,6 @@ import RWSDebug (-*->) value trace :== value // ---> trace -frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances var_heap /* MdM */ type_heap optional_dcl_icl_conversions - global_fun_range - :== (predef_symbols,hash_table,files,error,io,out, - Yes { fe_icl = {icl_mod & icl_functions=fun_defs } - , fe_dcls = dcl_mods - , fe_components = components - , fe_varHeap = var_heap -// MdM - , fe_typeHeap = type_heap -// ... MdM - , fe_dclIclConversions = optional_dcl_icl_conversions - , fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions - , fe_globalFunctions = global_fun_range - , fe_arrayInstances = array_instances - } - ) - build_optional_icl_dcl_conversions :: !Int !(Optional {# Index}) -> Optional {# Index} build_optional_icl_dcl_conversions size No = Yes (buildIclDclConversions size {}) @@ -78,46 +57,68 @@ instance == FrontEndPhase where (==) a b = equal_constructor a b -frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree) -frontEndInterface upToPhase mod_ident search_paths list_inferred_types predef_symbols hash_table files error io out +frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions + global_fun_range heaps + :== (Yes { + fe_icl = {icl_mod & icl_functions=fun_defs } + , fe_dcls = dcl_mods + , fe_components = components + , fe_dclIclConversions = optional_dcl_icl_conversions + , fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions + , fe_globalFunctions = global_fun_range + , fe_arrayInstances = array_instances + }, {},0,0,predef_symbols,hash_table,files,error,io,out,heaps + ) + +frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*Heaps -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File,!*Heaps) +frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out heaps # (ok, mod, hash_table, error, predef_symbols, files) - = wantModule cWantIclFile mod_ident NoPos (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files + = wantModule cWantIclFile mod_ident NoPos (hash_table ---> ("Parsing:", mod_ident)) error search_paths predef_symbols files | not ok - = (predef_symbols, hash_table, files, error, io, out, No) - # (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 + = (No,{},0,0,predef_symbols, hash_table, files, error, io, out,heaps) + # cached_module_idents = [dcl_mod.dcl_name \\ dcl_mod<-:dcl_modules] + # (ok, mod, global_fun_range, mod_functions, optional_dcl_mod, modules, dcl_module_n_in_cache,n_functions_and_macros_in_dcl_modules,hash_table, error, predef_symbols, files) + = scanModule (mod -*-> "Scanning") cached_module_idents (size functions_and_macros) hash_table error search_paths predef_symbols files + /* JVG: */ +// # hash_table = {hash_table & hte_entries={}} + # hash_table = remove_icl_symbols_from_hash_table hash_table + /**/ | not ok - = (predef_symbols, hash_table, files, error, io, out, No) + = (No,{},0,0,predef_symbols, hash_table, files, error, io, out,heaps) # 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 global_fun_range mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table -*-> "Checking") error + (ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions,cached_functions_and_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error) + = checkModule mod global_fun_range mod_functions n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod modules dcl_modules functions_and_macros predef_symbols (symbol_table -*-> "Checking") error heaps hash_table = { hash_table & hte_symbol_heap = symbol_table} + | not ok - = (predef_symbols, hash_table, files, error, io, out, No) - # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared} = icl_mod + = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, heaps) + + #! (icl_functions,icl_mod) = select_and_remove_icl_functions_from_record icl_mod + with + select_and_remove_icl_functions_from_record :: !*IclModule -> (!.{#FunDef},!.IclModule) + select_and_remove_icl_functions_from_record icl_mod=:{icl_functions} = (icl_functions,{icl_mod & icl_functions={}}) + +// # {icl_functions,icl_instances,icl_specials,icl_common,icl_import} = icl_mod + # {icl_instances,icl_specials,icl_common,icl_import,icl_name,icl_imported_objects,icl_used_module_numbers} = icl_mod + // (components, icl_functions, error) = showComponents components 0 True icl_functions error - dcl_mods = {{dcl_mod & dcl_declared={dcls_import=[],dcls_local=[],dcls_explicit=[]}}\\ dcl_mod<-:dcl_mods} +// dcl_mods = {{dcl_mod & dcl_declared={dcls_import=[],dcls_local=[],dcls_explicit=[]}}\\ dcl_mod<-:dcl_mods} +// # dcl_mods = {{dcl_mod & dcl_declared={dcls_import={},dcls_local=[],dcls_local_for_import={},dcls_explicit={}}}\\ dcl_mod<-:dcl_mods} var_heap = heaps.hp_var_heap -// MdM type_heaps = heaps.hp_type_heaps -// ... MdM fun_defs = icl_functions array_instances = {ir_from=0, ir_to=0} | upToPhase == FrontEndPhaseCheck - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// var_heap optional_dcl_icl_conversions global_fun_range - var_heap type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM - - # (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error, out) - = typeProgram (components -*-> "Typing") fun_defs icl_specials list_inferred_types icl_common - icl_declared.dcls_import dcl_mods heaps predef_symbols error out + = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + + # (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error,out) + = typeProgram (components -*-> "Typing") main_dcl_module_n icl_functions icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers heaps predef_symbols error out + | not ok - = (predef_symbols, hash_table, files, error, io, out, No) + = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,heaps) # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials] // (components, fun_defs, error) = showTypes components 0 fun_defs error @@ -125,61 +126,84 @@ frontEndInterface upToPhase mod_ident search_paths list_inferred_types predef_sy // (fun_defs, error) = showFunctions array_instances fun_defs error | upToPhase == FrontEndPhaseTypeCheck - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// heaps.hp_var_heap optional_dcl_icl_conversions global_fun_range - heaps.hp_var_heap heaps.hp_type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM + = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap) - = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components -*-> "convertDynamics") fun_defs predef_symbols + = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap | upToPhase == FrontEndPhaseConvertDynamics - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// var_heap optional_dcl_icl_conversions global_fun_range - var_heap type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM - + # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} + = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps // (components, fun_defs, error) = showComponents components 0 True fun_defs error # (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap) - = analyseGroups common_defs array_instances (components -*-> "Transform") fun_defs var_heap expression_heap + = analyseGroups common_defs array_instances main_dcl_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap + (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) - = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap + = transformGroups cleanup_info main_dcl_module_n (components -*-> "Transform") fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap | upToPhase == FrontEndPhaseTransformGroups - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// var_heap optional_dcl_icl_conversions global_fun_range - var_heap type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM + # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} + = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps - # (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps - (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps + # (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule main_dcl_module_n common_defs (dcl_types -*-> "Convert icl") used_conses var_heap type_heaps + # (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule main_dcl_module_n dcl_mods common_defs (dcl_types -*-> "Convert dcl") used_conses var_heap type_heaps + +// (components, fun_defs, out) = showComponents components 0 False fun_defs out | upToPhase == FrontEndPhaseConvertModules - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// var_heap optional_dcl_icl_conversions global_fun_range - var_heap type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM + # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} + = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps // (components, fun_defs, out) = showComponents components 0 False fun_defs out # (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) - = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses + = convertCasesOfFunctionsIntoPatterns components main_dcl_module_n imported_funs common_defs fun_defs (dcl_types -*-> "Convert cases") used_conses 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 + #! (dcl_types, type_heaps, var_heap) + = convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs (dcl_types -*-> "Convert types") type_heaps var_heap + # heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps} // (components, fun_defs, error) = showTypes components 0 fun_defs error // (components, fun_defs, out) = showComponents components 0 False fun_defs out - = frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances -// MdM -// var_heap optional_dcl_icl_conversions global_fun_range - var_heap type_heaps.th_vars optional_dcl_icl_conversions global_fun_range -// ... MdM + #! fe ={ fe_icl = +// {icl_mod & icl_functions=fun_defs } + {icl_functions=fun_defs,icl_instances=icl_instances,icl_specials=icl_specials,icl_common=icl_common,icl_import=icl_import, + icl_name=icl_name,icl_imported_objects=icl_imported_objects,icl_used_module_numbers=icl_used_module_numbers } + + , fe_dcls = dcl_mods + , fe_components = components + , fe_dclIclConversions = optional_dcl_icl_conversions + , fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions + , fe_arrayInstances = array_instances,fe_globalFunctions=global_fun_range + } + = (Yes fe,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,heaps) + where + build_optional_icl_dcl_conversions :: !Int !(Optional {# Index}) -> Optional {# Index} + build_optional_icl_dcl_conversions size No + = Yes (build_icl_dcl_conversions size {}) + build_optional_icl_dcl_conversions size (Yes dcl_icl_conversions) + = Yes (build_icl_dcl_conversions size dcl_icl_conversions) + + build_icl_dcl_conversions :: !Int !{# Index} -> {# Index} + build_icl_dcl_conversions table_size dcl_icl_conversions + # dcl_table_size = size dcl_icl_conversions + icl_dcl_conversions = update_conversion_array 0 dcl_table_size dcl_icl_conversions (createArray table_size NoIndex) + = fill_empty_positions 0 table_size dcl_table_size icl_dcl_conversions + + update_conversion_array dcl_index dcl_table_size dcl_icl_conversions icl_conversions + | dcl_index < dcl_table_size + # icl_index = dcl_icl_conversions.[dcl_index] + = update_conversion_array (inc dcl_index) dcl_table_size dcl_icl_conversions + { icl_conversions & [icl_index] = dcl_index } + = icl_conversions + + fill_empty_positions next_index table_size next_new_index icl_conversions + | next_index < table_size + | icl_conversions.[next_index] == NoIndex + = fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index } + = fill_empty_positions (inc next_index) table_size next_new_index icl_conversions + = icl_conversions newSymbolTable :: !Int -> *{# SymbolTableEntry} newSymbolTable size diff --git a/frontend/hashtable.dcl b/frontend/hashtable.dcl index 2d1621f..72a5544 100644 --- a/frontend/hashtable.dcl +++ b/frontend/hashtable.dcl @@ -7,10 +7,13 @@ import syntax :: HashTable = { hte_symbol_heap :: !.SymbolTable , hte_entries :: !.{! .HashTableEntry} + , hte_mark :: !Int // 1 for .icl modules, otherwise 0 } newHashTable :: *HashTable +set_hte_mark :: !Int !*HashTable -> *HashTable + :: IdentClass = IC_Expression | IC_Type | IC_TypeAttr @@ -21,6 +24,9 @@ newHashTable :: *HashTable | IC_Instance ![Type] | IC_Unknown +:: BoxedIdent = {boxed_ident::!Ident} -putIdentInHashTable :: !String !IdentClass !*HashTable -> (!Ident, !*HashTable) +//putIdentInHashTable :: !String !IdentClass !*HashTable -> (!Ident, !*HashTable) +putIdentInHashTable :: !String !IdentClass !*HashTable -> (!BoxedIdent, !*HashTable) +remove_icl_symbols_from_hash_table :: !*HashTable -> *HashTable diff --git a/frontend/hashtable.icl b/frontend/hashtable.icl index ed90380..e9ebca4 100644 --- a/frontend/hashtable.icl +++ b/frontend/hashtable.icl @@ -2,13 +2,14 @@ implementation module hashtable import predef, syntax, StdCompare, compare_constructor - -:: HashTableEntry = HTE_Ident !String !SymbolPtr !IdentClass !HashTableEntry !HashTableEntry - | HTE_Empty +:: HashTableEntry + = HTE_Ident !Ident !IdentClass !Int !HashTableEntry !HashTableEntry + | HTE_Empty :: HashTable = { hte_symbol_heap :: !.SymbolTable , hte_entries :: !.{! .HashTableEntry} + , hte_mark :: !Int // 1 for .icl modules, otherwise 0 } :: IdentClass = IC_Expression @@ -21,8 +22,13 @@ import predef, syntax, StdCompare, compare_constructor | IC_Instance ![Type] | IC_Unknown +:: BoxedIdent = {boxed_ident::!Ident} + newHashTable :: *HashTable -newHashTable = { hte_symbol_heap = newHeap, hte_entries = { HTE_Empty \\ i <- [0 .. dec cHashTableSize] }} +newHashTable = { hte_symbol_heap = newHeap, hte_entries = { HTE_Empty \\ i <- [0 .. dec cHashTableSize] },hte_mark=0} + +set_hte_mark :: !Int !*HashTable -> *HashTable +set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark} instance =< IdentClass where @@ -74,26 +80,109 @@ where char = name.[index] = hash_value name index (val << 2 + toInt char) +/* putIdentInHashTable :: !String !IdentClass !*HashTable -> (!Ident, !*HashTable) -putIdentInHashTable name indent_class {hte_symbol_heap,hte_entries} +putIdentInHashTable name ident_class {hte_symbol_heap,hte_entries} # hash_val = hashValue name (entries,hte_entries) = replace hte_entries hash_val HTE_Empty - (ident, hte_symbol_heap, entries) = insert name indent_class hte_symbol_heap entries - (_,hte_entries) = replace hte_entries hash_val entries + (ident, hte_symbol_heap, entries) = insert name ident_class hte_symbol_heap entries + hte_entries = update hte_entries hash_val entries = (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries }) - where insert :: !String !IdentClass !*SymbolTable *HashTableEntry -> (!Ident, !*SymbolTable, !*HashTableEntry) - insert name indent_class hte_symbol_heap HTE_Empty + insert name ident_class hte_symbol_heap HTE_Empty # (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap - = ({ id_name = name, id_info = hte_symbol_ptr}, hte_symbol_heap, HTE_Ident name hte_symbol_ptr indent_class HTE_Empty HTE_Empty) - insert name indent_class hte_symbol_heap (HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) - # cmp = (name,indent_class) =< (hte_name,hte_class) + = ({ id_name = name, id_info = hte_symbol_ptr}, hte_symbol_heap, HTE_Ident name hte_symbol_ptr ident_class HTE_Empty HTE_Empty) + insert name ident_class hte_symbol_heap (HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) + # cmp = (name,ident_class) =< (hte_name,hte_class) | cmp == Equal = ({ id_name = hte_name, id_info = hte_symbol_ptr}, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) | cmp == Smaller - #! (ident, hte_symbol_heap, hte_left) = insert name indent_class hte_symbol_heap hte_left + #! (ident, hte_symbol_heap, hte_left) = insert name ident_class hte_symbol_heap hte_left = (ident, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) - #! (ident, hte_symbol_heap, hte_right) = insert name indent_class hte_symbol_heap hte_right + #! (ident, hte_symbol_heap, hte_right) = insert name ident_class hte_symbol_heap hte_right = (ident, hte_symbol_heap, HTE_Ident hte_name hte_symbol_ptr hte_class hte_left hte_right) +*/ +putIdentInHashTable :: !String !IdentClass !*HashTable -> (!BoxedIdent, !*HashTable) +putIdentInHashTable name ident_class {hte_symbol_heap,hte_entries,hte_mark} + # hash_val = hashValue name + (entries,hte_entries) = replace hte_entries hash_val HTE_Empty + (ident, hte_symbol_heap, entries) = insert name ident_class hte_mark hte_symbol_heap entries + hte_entries = update hte_entries hash_val entries + = (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark }) +where + insert :: !String !IdentClass !Int !*SymbolTable *HashTableEntry -> (!BoxedIdent, !*SymbolTable, !*HashTableEntry) + insert name ident_class hte_mark0 hte_symbol_heap HTE_Empty + # (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap + # ident = { id_name = name, id_info = hte_symbol_ptr} + = ({boxed_ident=ident}, hte_symbol_heap, HTE_Ident ident ident_class hte_mark0 HTE_Empty HTE_Empty) + insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{id_name,id_info} hte_class hte_mark hte_left hte_right) + # cmp = (name,ident_class) =< (id_name,hte_class) + | cmp == Equal + = ({boxed_ident=hte_ident}, hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right) + | cmp == Smaller + #! (boxed_ident, hte_symbol_heap, hte_left) = insert name ident_class hte_mark0 hte_symbol_heap hte_left + = (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right) + #! (boxed_ident, hte_symbol_heap, hte_right) = insert name ident_class hte_mark0 hte_symbol_heap hte_right + = (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right) + +remove_icl_symbols_from_hash_table :: !*HashTable -> *HashTable +remove_icl_symbols_from_hash_table hash_table=:{hte_entries} + # hte_entries=remove_icl_symbols_from_array 0 hte_entries + = {hash_table & hte_entries=hte_entries} + where + remove_icl_symbols_from_array i hte_entries + | i<size hte_entries + # (entries,hte_entries) = replace hte_entries i HTE_Empty + # (_,entries) = remove_icl_entries_from_tree entries + # hte_entries = update hte_entries i entries + = remove_icl_symbols_from_array (i+1) hte_entries + = hte_entries + + // a tuple with a dummy value is used to change the calling convention to improve reuse of nodes + remove_icl_entries_from_tree :: !*HashTableEntry -> (!Int,!.HashTableEntry); + remove_icl_entries_from_tree HTE_Empty + = (0,HTE_Empty) + remove_icl_entries_from_tree (HTE_Ident hte_ident hte_class 0 hte_left hte_right) + # (_,hte_left) = remove_icl_entries_from_tree hte_left + # (_,hte_right) = remove_icl_entries_from_tree hte_right + = (0,HTE_Ident hte_ident hte_class 0 hte_left hte_right) + remove_icl_entries_from_tree (HTE_Ident hte_ident hte_class _ hte_left hte_right) + # (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left + # (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right + = merge_trees hte_left hte_right depth_left depth_right + + remove_icl_entries_from_tree_and_compute_depth :: !*HashTableEntry -> (!Int,!.HashTableEntry); + remove_icl_entries_from_tree_and_compute_depth HTE_Empty + = (0,HTE_Empty) + remove_icl_entries_from_tree_and_compute_depth (HTE_Ident hte_ident hte_class 0 hte_left hte_right) + # (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left + # (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right + = (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class 0 hte_left hte_right) + remove_icl_entries_from_tree_and_compute_depth (HTE_Ident hte_ident hte_class _ hte_left hte_right) + # (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left + # (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right + = merge_trees hte_left hte_right depth_left depth_right + + // the returned depth is an estimate + merge_trees :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry) + merge_trees HTE_Empty hte_right depth_left depth_right + = (depth_right,hte_right) + merge_trees hte_left HTE_Empty depth_left depth_right + = (depth_left,hte_left) + merge_trees hte_left hte_right depth_left depth_right + | depth_left>=depth_right + = merge_trees_left hte_left hte_right depth_left depth_right + = merge_trees_right hte_left hte_right depth_left depth_right + where + merge_trees_left :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry) + merge_trees_left (HTE_Ident hte_ident hte_class hte_mark hte_left_left hte_left_right) hte_right depth_left depth_right + # (depth_right,hte_right)=merge_trees hte_left_right hte_right (depth_left-1) depth_right + # depth_right=depth_right+1 + = (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class hte_mark hte_left_left hte_right) + merge_trees_right :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry) + merge_trees_right hte_left (HTE_Ident hte_ident hte_class hte_mark hte_right_left hte_right_right) depth_left depth_right + # (depth_left,hte_left)=merge_trees hte_left hte_right_left depth_left (depth_right-1) + # depth_left=depth_left+1 + = (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class hte_mark hte_left hte_right_right) diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl index 509dd8f..4719aa2 100644 --- a/frontend/overloading.dcl +++ b/frontend/overloading.dcl @@ -36,7 +36,7 @@ import syntax, check, typesupport :: LocalTypePatternVariable :: DictionaryTypes :== [(Index, [ExprInfoPtr])] -tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState +tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState) :: TypeCodeInfo = @@ -45,9 +45,9 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Ind , tci_type_var_heap :: !.TypeVarHeap } -removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap +removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} //!*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) -updateDynamics :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} +updateDynamics :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) diff --git a/frontend/overloading.icl b/frontend/overloading.icl index ca3c7d3..392c525 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -129,17 +129,17 @@ containsContext new_tc [tc : tcs] FoundObject object :== object.glob_module <> NotFound ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound } -reduceContexts :: ![TypeContext] !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable] +reduceContexts :: ![TypeContext] !Int !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable] !(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin -> *(![ClassApplication], ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable], !(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) -reduceContexts [] defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error +reduceContexts [] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error = ([], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) -reduceContexts [tc : tcs] defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error +reduceContexts [tc : tcs] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error # (appl, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) = try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) - = reduceContexts tcs defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error + = reduceContexts tcs main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error = ([appl : appls], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) where @@ -179,7 +179,7 @@ where = ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) # (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) - = reduceContexts contexts defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error + = reduceContexts contexts main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error (constraints, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) = reduce_contexts_in_constraints tc_types class_args class_context defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error @@ -328,7 +328,8 @@ where = case opt_record of Yes record # (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances - -> ({ rc_class = ins_class, rc_inst_module = cIclModIndex, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, +// -> ({ rc_class = ins_class, rc_inst_module = cIclModIndex, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, + -> ({ rc_class = ins_class, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, special_instances, predef_symbols_type_heaps, error) No -> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, @@ -551,9 +552,9 @@ where :: DictionaryTypes :== [(Index, [ExprInfoPtr])] -tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState +tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState) -tryToSolveOverloading ocs defs instance_info coercion_env os +tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os # (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os) | os.os_error.ea_ok # (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap) @@ -591,7 +592,7 @@ where | otherwise # (class_applications, new_contexts, os_special_instances, type_pattern_vars, (os_var_heap, os_type_heaps), coercion_env, os_predef_symbols, os_error) - = reduceContexts oc_context defs instance_info new_contexts os_special_instances type_pattern_vars + = reduceContexts oc_context main_dcl_module_n defs instance_info new_contexts os_special_instances type_pattern_vars (os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error = ([ (oc_symbol, fun_index, over_info_ptr, class_applications) : reduced_calls ], new_contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap, @@ -830,9 +831,9 @@ getClassVariable symb var_info_ptr var_heap error -> (symb, var_info_ptr, var_heap, overloadingError symb error) -updateDynamics :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} +updateDynamics :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) -updateDynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols +updateDynamics funs type_pattern_vars main_dcl_module_n fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols | error.ea_ok = update_dynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols = (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) @@ -848,10 +849,11 @@ where # (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ [] (TransformedBody tb) = fun_body - (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols /*, ui_new_variables */}) = updateExpression fi_group_index tb.tb_rhs + (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols} /*, ui_new_variables */}) + = updateExpression fi_group_index tb.tb_rhs { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = [], - ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error - /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols} //, ui_new_variables = [] } + ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error , /*ui_new_variables = [],*/ + ui_x={x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs} } // /* MV */ , fun_info = { fun_info & fi_local_vars = ui_new_variables ++ fun_info.fi_local_vars }} @@ -863,10 +865,10 @@ where = update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def }) ui_fun_env ui_symbol_heap type_code_info ui_var_heap ui_error predef_symbols -removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap +removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int!*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) -removeOverloadedFunctions group type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols +removeOverloadedFunctions group type_pattern_vars main_dcl_module_n fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols | error.ea_ok # (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) = foldSt (remove_overloaded_function type_pattern_vars) group (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) @@ -882,10 +884,10 @@ where (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables - (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols}) //, ui_new_variables }) + (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols}}) //, ui_new_variables }) = updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap, ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error - /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols} + /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args, fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars } } @@ -1087,10 +1089,13 @@ where , ui_fun_defs :: !.{# FunDef} , ui_fun_env :: !.{! FunctionType} , ui_error :: !.ErrorAdmin -// MV .. - , ui_type_code_info :: !.TypeCodeInfo - , ui_predef_symbols :: !.{#PredefinedSymbol} -// .. MV + , ui_x :: !.UpdateInfoX + } + +:: UpdateInfoX = { + x_type_code_info :: !.TypeCodeInfo + , x_predef_symbols :: !.{#PredefinedSymbol} + , x_main_dcl_module_n :: !Int } class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo) @@ -1106,7 +1111,8 @@ where ui = { ui & ui_symbol_heap = ui_symbol_heap } = case symb_info of EI_Empty - #! fun_index = get_recursive_fun_index group_index symb_kind ui.ui_fun_defs + #! main_dcl_module_n = ui.ui_x.UpdateInfoX.x_main_dcl_module_n + #! fun_index = get_recursive_fun_index group_index symb_kind main_dcl_module_n ui.ui_fun_defs | fun_index == NoIndex -> (App { app & app_args = app_args }, ui) # (CheckedType {st_context}, ui) = ui!ui_fun_env.[fun_index] @@ -1115,7 +1121,8 @@ where { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) EI_Context context_args # (app_args, ui=:{ui_var_heap, ui_error}) = adjustClassExpressions symb_name context_args app_args ui - #! fun_index = get_recursive_fun_index group_index symb_kind ui.ui_fun_defs + #! main_dcl_module_n = ui.ui_x.UpdateInfoX.x_main_dcl_module_n + #! fun_index = get_recursive_fun_index group_index symb_kind main_dcl_module_n ui.ui_fun_defs | fun_index == NoIndex # app = { app & app_symb = { symb & symb_arity = length context_args + symb_arity }, app_args = app_args} -> (App app, examine_calls context_args { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) @@ -1152,15 +1159,16 @@ where _ -> abort "build_context_arg (overloading.icl)" - get_recursive_fun_index :: !Index !SymbKind !{# FunDef} -> Index - get_recursive_fun_index group_index (SK_Function {glob_module,glob_object}) fun_defs - | glob_module == cIclModIndex + get_recursive_fun_index :: !Index !SymbKind Int !{# FunDef} -> Index + get_recursive_fun_index group_index (SK_Function {glob_module,glob_object}) main_dcl_module_n fun_defs +// | glob_module == cIclModIndex + | glob_module == main_dcl_module_n # {fun_info, fun_index} = fun_defs.[glob_object] | fun_info.fi_group_index == group_index = fun_index = NoIndex = NoIndex - get_recursive_fun_index group_index _ fun_defs + get_recursive_fun_index group_index _ main_dcl_module_n fun_defs = NoIndex build_application def_symbol=:{glob_object} context_args orig_args nr_of_orig_args app_info_ptr @@ -1175,7 +1183,8 @@ where = ui new_call mod_index symb_index ui=:{ui_instance_calls,ui_fun_defs} - | mod_index == cIclModIndex && symb_index < size ui_fun_defs +// | mod_index == cIclModIndex && symb_index < size ui_fun_defs + | mod_index == ui.ui_x.UpdateInfoX.x_main_dcl_module_n && symb_index < size ui_fun_defs # ui_instance_calls = add_call symb_index ui_instance_calls = { ui & ui_instance_calls = ui_instance_calls } = ui @@ -1396,14 +1405,15 @@ where { ui & ui_local_vars = [cyclic_fv : ui.ui_local_vars]}) getSymbol :: !Int !(!(Global !Int) -> !SymbKind) !Int !*UpdateInfo -> (SymbIdent,*UpdateInfo) - getSymbol index symb_kind arity ui=:{ui_predef_symbols} - # ({pds_module, pds_def, pds_ident}, ui_predef_symbols) = ui_predef_symbols![index] - ui = { ui & ui_predef_symbols = ui_predef_symbols} + getSymbol index symb_kind arity ui=:{ui_x=ui_x=:{x_predef_symbols}} + # ({pds_module, pds_def, pds_ident}, x_predef_symbols) = x_predef_symbols![index] + ui_x = { ui_x & x_predef_symbols = x_predef_symbols} + ui={ui & ui_x=ui_x} symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity } = (symbol,ui) get_constructor :: !Int !*UpdateInfo -> !(!Expression,!*UpdateInfo) - get_constructor index ui=:{ui_type_code_info={tci_instances}} + get_constructor index ui=:{ui_x={x_type_code_info={tci_instances}}} /* ** MV ** Inefficiency. The correct gtci_type referred to by index has to be selected from the list of diff --git a/frontend/parse.icl b/frontend/parse.icl index cd9ffa4..a7a25c5 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -107,13 +107,23 @@ makeConsExpression a1 a2 pState=:{ps_pre_def_symbols} class try a :: !Token !*ParseState -> (!Optional a, !*ParseState) class want a :: !*ParseState -> (!a, !*ParseState) -stringToIdent :: !String !IdentClass !*ParseState -> (!Ident, !*ParseState) -stringToIdent ident ident_class pState=:{ps_hash_table} +stringToIdent s i p :== (ident,parse_state) + where + ({boxed_ident=ident},parse_state) = stringToBoxedIdent s i p + +//stringToIdent :: !String !IdentClass !*ParseState -> (!Ident, !*ParseState) +stringToBoxedIdent :: !String !IdentClass !*ParseState -> (!BoxedIdent, !*ParseState) +stringToBoxedIdent ident ident_class pState=:{ps_hash_table} # (ident, ps_hash_table) = putIdentInHashTable ident ident_class ps_hash_table = (ident, { pState & ps_hash_table = ps_hash_table } ) -internalIdent :: !String !*ParseState -> (!Ident, !*ParseState) -internalIdent prefix pState +internalIdent s p :== (ident,parse_state) + where + ({boxed_ident=ident},parse_state) = internaBoxedlIdent s p + +//internalIdent :: !String !*ParseState -> (!Ident, !*ParseState) +internaBoxedlIdent :: !String !*ParseState -> (!BoxedIdent, !*ParseState) +internaBoxedlIdent prefix pState # ({fp_line,fp_col},pState=:{ps_hash_table}) = getPosition pState // MW4 was: (changed to make it compatible with conventions used in postparse) // case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col @@ -246,17 +256,19 @@ isIclContext context :== not (isDclContext context) cWantIclFile :== True cWantDclFile :== False -// MW3 was:wantModule :: !Bool !Ident !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files wantModule :: !Bool !Ident !Position !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) wantModule iclmodule file_id=:{id_name} import_file_position hash_table error searchPaths pre_def_symbols files # file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") = case openScanner file_name searchPaths files of - (Yes scanState, files) -> initModule file_name scanState hash_table error pre_def_symbols files - (No , files) -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in -// MW3 was: (False, mod, hash_table, error <<< "Could not open: " <<< file_name <<< "\n", pre_def_symbols, files) - (False, mod, hash_table, error <<< import_file_position <<< ":could not open " <<< file_name <<< "\n", - pre_def_symbols, files) + (Yes scanState, files) + # hash_table=set_hte_mark (if iclmodule 1 0) hash_table + # (ok,mod,hash_table,file,pre_def_symbols,files) = initModule file_name scanState hash_table error pre_def_symbols files + # hash_table=set_hte_mark 0 hash_table + ->(ok,mod,hash_table,file,pre_def_symbols,files) + (No, files) + -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in + (False, mod, hash_table, error <<< import_file_position <<< ":could not open " <<< file_name <<< "\n", pre_def_symbols, files) where initModule :: String ScanState !*HashTable !*File !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) @@ -1437,9 +1449,9 @@ adjustAttribute attr type pState stringToType :: !String !ParseState -> (!Type, !ParseState) stringToType name pState - # (id, pState) = stringToIdent name IC_Type pState | isLowerCaseName name = nameToTypeVar name pState + # (id, pState) = stringToIdent name IC_Type pState = (TA (MakeNewTypeSymbIdent id 0) [], pState) /* | isUpperCaseName name = (TA (MakeNewTypeSymbIdent id 0) [], pState) diff --git a/frontend/postparse.dcl b/frontend/postparse.dcl index 9e5f2a1..eb388b7 100644 --- a/frontend/postparse.dcl +++ b/frontend/postparse.dcl @@ -4,5 +4,5 @@ import StdEnv import syntax, parse, predef -scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files - -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) +scanModule :: !ParsedModule ![Ident] !Int !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !Optional ScannedModule, ![ScannedModule],!Int,!Int,!*HashTable, !*File, !*PredefinedSymbols, !*Files) diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 6ef3cc4..ae404a2 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -4,10 +4,6 @@ import StdEnv import syntax, parse, predef, utilities, StdCompare import RWSDebug -/** - -**/ - :: *CollectAdmin = { ca_error :: !*ParseErrorAdmin , ca_fun_count :: !Int @@ -56,8 +52,8 @@ exprToRhs expr prefixAndPositionToIdent :: !String !LineAndColumn !*CollectAdmin -> (!Ident, !*CollectAdmin) prefixAndPositionToIdent prefix {lc_line, lc_column} ca=:{ca_hash_table} - # (ident, ca_hash_table) - = putIdentInHashTable (prefix +++ ";" +++ toString lc_line +++ ";" +++ toString lc_column) IC_Expression ca_hash_table +// # (ident, ca_hash_table) = putIdentInHashTable (prefix +++ ";" +++ toString lc_line +++ ";" +++ toString lc_column) IC_Expression ca_hash_table + # ({boxed_ident=ident}, ca_hash_table) = putIdentInHashTable (prefix +++ ";" +++ toString lc_line +++ ";" +++ toString lc_column) IC_Expression ca_hash_table = (ident, { ca & ca_hash_table = ca_hash_table } ) (`) infixl 9 @@ -658,45 +654,49 @@ transformArrayDenot exprs pi [{bind_dst=toParsedExpr i pi, bind_src=expr} \\ expr <- exprs & i <- [0..]] pi -scanModules :: [ParsedImport] [ScannedModule] SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) -scanModules [] parsed_modules searchPaths files ca +scanModules :: [ParsedImport] [ScannedModule] [Ident] SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) +scanModules [] parsed_modules cached_modules searchPaths files ca = (True, parsed_modules, files, ca) -// MW3 was:scanModules [{import_module,import_symbols} : mods] parsed_modules searchPaths files ca -scanModules [{import_module,import_symbols,import_file_position} : mods] parsed_modules searchPaths files ca - # (found, mod) = try_to_find import_module parsed_modules - | found - = scanModules mods parsed_modules searchPaths files ca +scanModules [{import_module,import_symbols,import_file_position} : mods] parsed_modules cached_modules searchPaths files ca + | in_cache import_module cached_modules + = scanModules mods parsed_modules cached_modules searchPaths files ca + | try_to_find import_module parsed_modules + = scanModules mods parsed_modules cached_modules searchPaths files ca # (succ, parsed_modules, files, ca) -// MW3 was: = parseAndScanDclModule import_module parsed_modules searchPaths files ca - = parseAndScanDclModule import_module import_file_position parsed_modules searchPaths files ca + = parseAndScanDclModule import_module import_file_position parsed_modules cached_modules searchPaths files ca (mods_succ, parsed_modules, files, ca) - = scanModules mods parsed_modules searchPaths files ca + = scanModules mods parsed_modules cached_modules searchPaths files ca = (succ && mods_succ, parsed_modules, files, ca) where - try_to_find :: Ident [ScannedModule] -> (Bool, ScannedModule) + in_cache mod_id [] + = False + in_cache mod_id [cached_module_ident : pmods] + | mod_id==cached_module_ident + =True + = in_cache mod_id pmods + + try_to_find :: Ident [ScannedModule] -> Bool try_to_find mod_id [] - = (False, abort "module not found") + = False try_to_find mod_id [pmod : pmods] | mod_id == pmod.mod_name - = (True, pmod) + =True = try_to_find mod_id pmods MakeEmptyModule name :== { mod_name = name, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macros = { ir_from = 0, ir_to = 0 }, def_members = [], def_funtypes = [], def_instances = [] } } -//MW3 was:parseAndScanDclModule :: !Ident ![ScannedModule] !SearchPaths !*Files !*CollectAdmin -parseAndScanDclModule :: !Ident !Position ![ScannedModule] !SearchPaths !*Files !*CollectAdmin +parseAndScanDclModule :: !Ident !Position ![ScannedModule] ![Ident] !SearchPaths !*Files !*CollectAdmin -> *(!Bool, ![ScannedModule], !*Files, !*CollectAdmin) -parseAndScanDclModule dcl_module import_file_position parsed_modules searchPaths files ca +parseAndScanDclModule dcl_module import_file_position parsed_modules cached_modules searchPaths files ca # {ca_error, ca_fun_count, ca_rev_fun_defs, ca_predefs, ca_u_predefs, ca_hash_table} = ca hash_table = ca_hash_table pea_file = ca_error.pea_file predefs = ca_u_predefs // MW3 was: # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module hash_table pea_file searchPaths predefs files - # (parse_ok, mod, hash_table, err_file, predefs, files) - = wantModule cWantDclFile dcl_module import_file_position hash_table pea_file searchPaths predefs files + # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module import_file_position hash_table pea_file searchPaths predefs files # ca = {ca_hash_table=hash_table, ca_error={pea_file=err_file,pea_ok=True}, ca_u_predefs=predefs, ca_fun_count=ca_fun_count, ca_rev_fun_defs=ca_rev_fun_defs, ca_predefs=ca_predefs} | parse_ok = scan_dcl_module mod parsed_modules searchPaths files ca @@ -715,53 +715,94 @@ where mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros = range }} (import_ok, parsed_modules, files, ca) - = scanModules imports [mod : parsed_modules] searchPaths files ca + = scanModules imports [mod : parsed_modules] cached_modules searchPaths files ca = (pea_ok && import_ok, parsed_modules, files, ca) -scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files - -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) -scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} hash_table err_file searchPaths predefs files +scanModule :: !ParsedModule ![Ident] !Int !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files + -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !Optional ScannedModule, ![ScannedModule],!Int,!Int,!*HashTable, !*File, !*PredefinedSymbols, !*Files) +scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} cached_modules first_new_function_or_macro_index hash_table err_file searchPaths predefs files # (predefIdents, predefs) = SelectPredefinedIdents predefs # ca = { ca_error = {pea_file = err_file, pea_ok = True} - , ca_fun_count = 0 + , ca_fun_count = first_new_function_or_macro_index , ca_rev_fun_defs = [] , ca_predefs = predefIdents , ca_u_predefs = predefs , ca_hash_table = hash_table } (fun_defs, defs, imports, imported_objects, ca) = reorganiseDefinitions True pdefs 0 0 0 ca - fun_count = length fun_defs + + (import_dcl_ok, optional_parsed_dcl_mod,dcl_module_n,parsed_modules, cached_modules,files, ca) + = scan_dcl_module mod_name mod_type files ca + (import_dcls_ok, parsed_modules, files, ca) + = scanModules imports parsed_modules cached_modules searchPaths files ca + + (pea_dcl_ok,optional_dcl_mod,ca) = collect_main_dcl_module optional_parsed_dcl_mod dcl_module_n ca + + (n_functions_and_macros_in_dcl_modules,ca) =ca!ca_fun_count + + modules = reverse parsed_modules + + import_dcl_ok = import_dcl_ok && pea_dcl_ok; + + ca = {ca & ca_hash_table=set_hte_mark 1 ca.ca_hash_table} + (fun_defs, ca) = collectFunctions fun_defs ca (fun_range, ca) = addFunctionsRange fun_defs ca (macro_defs, ca) = collectFunctions defs.def_macros ca (macro_range, ca) = addFunctionsRange macro_defs ca - (def_instances, ca) - = collectFunctions defs.def_instances ca + (def_instances, ca) = collectFunctions defs.def_instances ca + + ca = {ca & ca_hash_table=set_hte_mark 0 ca.ca_hash_table} + (pea_ok, ca) = ca!ca_error.pea_ok - (import_dcl_ok, parsed_modules, files, ca) - = scan_dcl_module mod_name mod_type searchPaths files ca - (import_dcls_ok, parsed_modules, files, ca) - = scanModules imports parsed_modules searchPaths files ca - { ca_error = {pea_file = err_file} - , ca_predefs = predefs - , ca_rev_fun_defs - , ca_u_predefs - , ca_hash_table = hash_table - } - = ca + + { ca_error = {pea_file = err_file}, ca_predefs = predefs, ca_rev_fun_defs, ca_u_predefs, ca_hash_table = hash_table } = ca mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_instances = def_instances, def_macros = macro_range }} - [dcl_mod : modules] = reverse parsed_modules - (pre_def_mod, ca_u_predefs) = buildPredefinedModule ca_u_predefs - = (pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_range, reverse ca_rev_fun_defs, dcl_mod, pre_def_mod, modules, hash_table, err_file, ca_u_predefs, files) +// (pre_def_mod, ca_u_predefs) = buildPredefinedModule ca_u_predefs + = (pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_range, reverse ca_rev_fun_defs, optional_dcl_mod, /*pre_def_mod,*/ modules, dcl_module_n,n_functions_and_macros_in_dcl_modules,hash_table, err_file, ca_u_predefs, files) where - scan_dcl_module :: Ident ModuleKind SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) - scan_dcl_module mod_name MK_Main searchPaths files ca - = (True, [MakeEmptyModule mod_name], files, ca) - scan_dcl_module mod_name MK_None searchPaths files ca - = (True, [MakeEmptyModule mod_name], files, ca) - scan_dcl_module mod_name kind searchPaths files ca - = parseAndScanDclModule mod_name NoPos [] searchPaths files ca + scan_dcl_module :: Ident ModuleKind *Files *CollectAdmin -> (!Bool,!Optional (Module (CollectedDefinitions (ParsedInstance FunDef) [FunDef])),!Int,![ScannedModule],![Ident],!*Files,!*CollectAdmin) + scan_dcl_module mod_name MK_Main files ca + = (True, No,NoIndex,[], cached_modules,files, ca) + scan_dcl_module mod_name MK_None files ca + = (True, No,NoIndex,[], cached_modules,files, ca) + scan_dcl_module mod_name kind files ca + # module_n_in_cache = in_cache 0 cached_modules; + with + in_cache module_n [] + = NoIndex + in_cache module_n [cached_module_ident : pmods] + | mod_name==cached_module_ident + = module_n + = in_cache (module_n+1) pmods + | module_n_in_cache<>NoIndex + = (True,No,module_n_in_cache,[],cached_modules,files,ca) + # {ca_error, ca_fun_count, ca_rev_fun_defs, ca_predefs, ca_u_predefs, ca_hash_table} = ca + hash_table = ca_hash_table + pea_file = ca_error.pea_file + predefs = ca_u_predefs + # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile mod_name NoPos hash_table pea_file searchPaths predefs files + # ca = {ca_hash_table=hash_table, ca_error={pea_file=err_file,pea_ok=True}, ca_u_predefs=predefs, ca_fun_count=ca_fun_count, ca_rev_fun_defs=ca_rev_fun_defs, ca_predefs=ca_predefs} + | not parse_ok + = (False, No,NoIndex, [],cached_modules, files, ca) + # pdefs = mod.mod_defs + # (_, defs, imports, imported_objects, ca) = reorganiseDefinitions False pdefs 0 0 0 ca + # mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = defs} + # cached_modules = [mod.mod_name:cached_modules] + # (import_ok, parsed_modules, files, ca) = scanModules imports [] cached_modules searchPaths files ca + = (import_ok, Yes mod, NoIndex,parsed_modules, cached_modules,files, ca) + + collect_main_dcl_module (Yes mod=:{mod_defs=defs}) dcl_module_n ca + # (macro_defs, ca) = collectFunctions defs.def_macros ca + (range, ca) = addFunctionsRange macro_defs ca + (pea_ok,ca) = ca!ca_error.pea_ok + mod = { mod & mod_defs = { defs & def_macros = range }} + = (pea_ok,Yes mod,ca) + collect_main_dcl_module No dcl_module_n ca + | dcl_module_n==NoIndex + = (True,Yes (MakeEmptyModule mod_name),ca) + = (True,No,ca) instance collectFunctions (ParsedInstance a) | collectFunctions a where collectFunctions inst=:{pi_members} ca @@ -1044,18 +1085,15 @@ reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca reorganiseLocalDefinitions [] ca = ([], [], ca) - belongsToTypeSpec name prio new_name is_infix :== name == new_name && sameFixity prio is_infix - determineArity :: [ParsedExpr] (Optional SymbolType) -> Int determineArity args (Yes {st_arity}) = st_arity determineArity args No = length args - sameFixity :: Priority Bool -> Bool sameFixity (Prio _ _) is_infix = is_infix diff --git a/frontend/predef.icl b/frontend/predef.icl index c28aa2d..c9dc1eb 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -73,6 +73,7 @@ PD_TypeCodeClass :== 122 PD_TypeObjectType :== 124 PD_TypeConsSymbol :== 125 PD_unify :== 126 +// MV .. PD_coerce :== 127 PD_variablePlaceholder :== 128 PD_StdDynamics :== 129 @@ -96,7 +97,8 @@ PD_NrOfPredefSymbols :== 133 (<<-) infixl (<<-) (array, hash_table) (name, table_kind, index) - # (id, hash_table) = putIdentInHashTable name table_kind hash_table +// # (id, hash_table) = putIdentInHashTable name table_kind hash_table + # ({boxed_ident=id}, hash_table) = putIdentInHashTable name table_kind hash_table = ({ array & [index] = { pds_ident = id, pds_module = NoIndex, pds_def = NoIndex } }, hash_table) GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 @@ -191,7 +193,6 @@ cTCMemberSymbIndex :== 0 cTCInstanceSymbIndex :== 0 - buildPredefinedModule :: !*PredefinedSymbols -> (!ScannedModule, !.PredefinedSymbols) buildPredefinedModule pre_def_symbols # (type_var_id, pre_def_symbols) = pre_def_symbols![PD_TypeVar_a0] @@ -228,10 +229,9 @@ buildPredefinedModule pre_def_symbols (class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols = ({ mod_name = pre_mod_id, mod_type = MK_System, mod_imports = [], mod_imported_objects = [], mod_defs = { - def_types = [string_def, list_def : type_defs], - def_constructors = [ParsedConstructorToConsDef cons_def, ParsedConstructorToConsDef nil_def : cons_defs], - def_selectors = [], def_classes = [class_def], def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], - def_funtypes = [alias_dummy_type], def_instances = [] }}, pre_def_symbols) + def_types = [string_def, list_def : type_defs], def_constructors + = [ParsedConstructorToConsDef cons_def, ParsedConstructorToConsDef nil_def : cons_defs], def_selectors = [], def_classes = [class_def], + def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], def_funtypes = [alias_dummy_type], def_instances = [] }}, pre_def_symbols) where add_tuple_defs pre_mod_id tup_arity type_defs cons_defs pre_def_symbols | tup_arity >= 2 @@ -290,6 +290,3 @@ where = { ft_symb = alias_dummy_id, ft_arity = 1, ft_priority = NoPrio, ft_type = id_symbol_type, ft_pos = NoPos, ft_specials = SP_None, ft_type_ptr = nilPtr } // ..MW - - - diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index cda1c8c..efb68d2 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -71,7 +71,6 @@ instance toString Ident :: ParsedModule :== Module [ParsedDefinition] :: ScannedModule :== Module (CollectedDefinitions (ParsedInstance FunDef) IndexRange) - :: ModuleKind = MK_Main | MK_Module | MK_System | MK_None @@ -80,7 +79,6 @@ instance toString Ident | TypeSpec !AType | EmptyRhs !BITVECT - :: CollectedDefinitions instance_kind macro_defs = { def_types :: ![TypeDef TypeRhs] , def_constructors :: ![ConsDef] @@ -539,6 +537,7 @@ cNonRecursiveAppl :== False :: SymbKind = SK_Unknown | SK_Function !(Global Index) + | SK_LocalMacroFunction !Index | SK_OverloadedFunction !(Global Index) | SK_Constructor !(Global Index) | SK_Macro !(Global Index) @@ -1170,8 +1169,11 @@ ErrorToString :: Error -> String */ -EmptySymbolTableEntry :== - { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" } +EmptySymbolTableEntry :== EmptySymbolTableEntryCAF.boxed_symbol_table_entry + +::BoxedSymbolTableEntry = {boxed_symbol_table_entry::!SymbolTableEntry} + +EmptySymbolTableEntryCAF :: BoxedSymbolTableEntry cNotAGroupNumber :== -1 @@ -1193,12 +1195,20 @@ PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } NoPropClass :== 0 PropClass :== bitnot 0 +newTypeSymbIdentCAF :: TypeSymbIdent; + +//MakeNewTypeSymbIdent name arity +// :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + MakeNewTypeSymbIdent name arity - :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + :== {newTypeSymbIdentCAF & type_name=name, type_arity=arity } + +//MakeTypeSymbIdent type_index name arity +// :== { type_name = name, type_arity = arity, type_index = type_index, +// type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} MakeTypeSymbIdent type_index name arity - :== { type_name = name, type_arity = arity, type_index = type_index, - type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} + :== { newTypeSymbIdentCAF & type_name = name, type_arity = arity, type_index = type_index } MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity } MakeConstant name :== MakeSymbIdent name 0 @@ -1215,7 +1225,6 @@ ParsedConstructorToConsDef pc :== st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []}, cons_exi_vars = pc.pc_exi_vars, cons_type_ptr = nilPtr, cons_arg_vars = [] } - ParsedInstanceToClassInstance pi members :== { ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident, ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [], diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 8fb217a..086c7b3 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -507,6 +507,7 @@ cNotVarNumber :== -1 :: SymbKind = SK_Unknown | SK_Function !(Global Index) + | SK_LocalMacroFunction !Index | SK_OverloadedFunction !(Global Index) | SK_Constructor !(Global Index) | SK_Macro !(Global Index) @@ -1293,6 +1294,7 @@ where instance <<< SymbIdent where (<<<) file symb=:{symb_kind = SK_Function symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index (<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index (<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index } = file <<< symb.symb_name <<< "[o]@" <<< symb_index (<<<) file symb = file <<< symb.symb_name @@ -1455,7 +1457,7 @@ where instance <<< Selection where (<<<) file (RecordSelection selector _) = file <<< selector - (<<<) file (ArraySelection _ _ index_expr) = file <<< '[' <<< index_expr <<< ']' + (<<<) file (ArraySelection {glob_object={ds_index}} _ index_expr) = file <<< '<' <<< ds_index <<< '>' <<< '[' <<< index_expr <<< ']' (<<<) file (DictionarySelection var selections _ index_expr) = file <<< '(' <<< var <<< '.' <<< selections <<< ')' <<< '[' <<< index_expr <<< ']' instance <<< LocalDefs @@ -1830,8 +1832,15 @@ instance == Annotation where (==) a1 a2 = equal_constructor a1 a2 -EmptySymbolTableEntry :== - { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" } +EmptySymbolTableEntry :== EmptySymbolTableEntryCAF.boxed_symbol_table_entry + +::BoxedSymbolTableEntry = {boxed_symbol_table_entry::!SymbolTableEntry} + +EmptySymbolTableEntryCAF :: BoxedSymbolTableEntry +EmptySymbolTableEntryCAF =: {boxed_symbol_table_entry = { ste_kind = STE_Empty, ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = abort_empty_SymbolTableEntry } } + +abort_empty_SymbolTableEntry :: a +abort_empty_SymbolTableEntry = abort "empty SymbolTableEntry" cNotAGroupNumber :== -1 @@ -1853,10 +1862,23 @@ PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } NoPropClass :== 0 PropClass :== bitnot 0 +newTypeSymbIdentCAF :: TypeSymbIdent; +newTypeSymbIdentCAF =: MakeTypeSymbIdentMacro { glob_object = NoIndex, glob_module = NoIndex } {id_name="",id_info=nilPtr} 0 + +//MakeNewTypeSymbIdent name arity +// :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + MakeNewTypeSymbIdent name arity - :== MakeTypeSymbIdent { glob_object = NoIndex, glob_module = NoIndex } name arity + :== {newTypeSymbIdentCAF & type_name=name, type_arity=arity } + +//MakeTypeSymbIdent type_index name arity +// :== { type_name = name, type_arity = arity, type_index = type_index, +// type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} MakeTypeSymbIdent type_index name arity + :== { newTypeSymbIdentCAF & type_name = name, type_arity = arity, type_index = type_index } + +MakeTypeSymbIdentMacro type_index name arity :== { type_name = name, type_arity = arity, type_index = type_index, type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }} diff --git a/frontend/trans.dcl b/frontend/trans.dcl index 640fc0a..dd6d153 100644 --- a/frontend/trans.dcl +++ b/frontend/trans.dcl @@ -10,10 +10,10 @@ cAccumulating :== -3 :: CleanupInfo -analyseGroups :: !{# CommonDefs} !IndexRange !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap +analyseGroups :: !{# CommonDefs} !IndexRange !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap -> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) -transformGroups :: !CleanupInfo !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } +transformGroups :: !CleanupInfo !Int !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap -> (!*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) @@ -21,7 +21,7 @@ partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef :: ImportedConstructors :== [Global Index] -convertSymbolType :: !{# CommonDefs} !SymbolType !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap +convertSymbolType :: !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] diff --git a/frontend/transform.icl b/frontend/transform.icl index 42dee93..6751298 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -4,10 +4,16 @@ import syntax, check, StdCompare, utilities, RWSDebug :: LiftState = { ls_var_heap :: !.VarHeap - , ls_fun_defs :: !.{#FunDef} +// , ls_fun_defs :: !.{#FunDef} + , ls_x :: !.LiftStateX , ls_expr_heap :: !.ExpressionHeap } +:: LiftStateX = { + x_fun_defs :: !.{#FunDef}, + x_main_dcl_module_n :: !Int + } + class lift a :: !a !*LiftState -> (!a, !*LiftState) instance lift [a] | lift a @@ -94,8 +100,10 @@ instance lift App where lift app=:{app_symb = app_symbol=:{symb_arity,symb_kind = SK_Function {glob_object,glob_module}}, app_args} ls # (app_args, ls) = lift app_args ls - | glob_module == cIclModIndex - #! fun_def = ls.ls_fun_defs.[glob_object] +// | glob_module == cIclModIndex + | glob_module == ls.ls_x.LiftStateX.x_main_dcl_module_n +// #! fun_def = ls.ls_fun_defs.[glob_object] + #! fun_def = ls.ls_x.x_fun_defs.[glob_object] # {fun_info={fi_free_vars}} = fun_def fun_lifted = length fi_free_vars | fun_lifted > 0 @@ -120,6 +128,33 @@ where -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] var_heap expr_heap + lift app=:{app_symb = app_symbol=:{symb_arity,symb_kind = SK_LocalMacroFunction glob_object}, app_args} ls + # (app_args, ls) = lift app_args ls +// #! fun_def = ls.ls_fun_defs.[glob_object] + #! fun_def = ls.ls_x.x_fun_defs.[glob_object] + # {fun_info={fi_free_vars}} = fun_def + fun_lifted = length fi_free_vars + | fun_lifted > 0 + # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap + = ({ app & app_args = app_args, app_symb = { app_symbol & symb_arity = symb_arity + fun_lifted }}, + { ls & ls_var_heap = ls_var_heap, ls_expr_heap = ls_expr_heap }) + = ({ app & app_args = app_args }, ls) + where + add_free_variables :: ![FreeVar] ![Expression] !u:VarHeap !*ExpressionHeap -> (![Expression],!u:VarHeap,!*ExpressionHeap) + add_free_variables [] app_args var_heap expr_heap + = (app_args, var_heap, expr_heap) + add_free_variables [{fv_name, fv_info_ptr} : free_vars] app_args var_heap expr_heap + #! var_info = sreadPtr fv_info_ptr var_heap + = case var_info of + VI_LiftedVariable var_info_ptr + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + _ + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + lift app=:{app_args} ls # (app_args, ls) = lift app_args ls = ({ app & app_args = app_args }, ls) @@ -329,6 +364,8 @@ where where is_function_or_macro (SK_Function _) = True + is_function_or_macro (SK_LocalMacroFunction _) + = True is_function_or_macro (SK_Macro _) = True is_function_or_macro (SK_OverloadedFunction _) @@ -506,6 +543,7 @@ examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) -> ( [ fc : calls ], symbol_table <:= (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) + //unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo) unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} args fun_defs (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table}) # (let_binds, var_heap) = bind_expressions tb_args args [] es_var_heap @@ -624,12 +662,12 @@ where partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{! Group}, !*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) -partitionateAndLiftFunctions ranges mod_index alias_dummy fun_defs modules var_heap symbol_heap symbol_table error +partitionateAndLiftFunctions ranges main_dcl_module_n alias_dummy fun_defs modules var_heap symbol_heap symbol_table error #! max_fun_nr = size fun_defs # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } (fun_defs, modules, {pi_groups, pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error}) - = foldSt (partitionate_functions mod_index max_fun_nr) ranges (fun_defs, modules, partitioning_info) + = foldSt (partitionate_functions main_dcl_module_n max_fun_nr) ranges (fun_defs, modules, partitioning_info) groups = { {group_members = group} \\ group <- reverse pi_groups } = (groups, fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) where @@ -658,7 +696,9 @@ where -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = pi.pi_next_group }}, modules, {pi & pi_next_group = inc pi.pi_next_group, pi_groups = [ [fun_index] : pi.pi_groups]})) -> (max_fun_nr, (fun_defs, modules, pi)) - + BackendBody _ + -> abort "partitionate_function BackendBody" + visit_function mod_index max_fun_nr {fc_index} (min_dep, funs_modules_pi) # (next_min, funs_modules_pi) = partitionate_function mod_index max_fun_nr fc_index funs_modules_pi = (min next_min min_dep, funs_modules_pi) @@ -668,8 +708,10 @@ where | fun_number <= min_dep # (pi_deps, group_without_macros, group_without_funs, fun_defs) = close_group fun_index pi_deps [] [] max_fun_nr pi_next_group fun_defs - (fun_defs, pi_var_heap, pi_symbol_heap) - = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group fun_defs pi_var_heap pi_symbol_heap +// (fun_defs, pi_var_heap, pi_symbol_heap) + {ls_x={x_fun_defs=fun_defs}, ls_var_heap=pi_var_heap, ls_expr_heap=pi_symbol_heap} +// = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group cIclModIndex fun_defs pi_var_heap pi_symbol_heap + = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group main_dcl_module_n fun_defs pi_var_heap pi_symbol_heap (fun_defs, modules, es) = expand_macros_in_group mod_index group_without_funs (fun_defs, modules, { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, @@ -707,7 +749,6 @@ where fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars }} = ({ fun_and_macro_defs & [fun_index] = fun_def }, modules, es) -// ---> ("expand_macros", fun_symb, fi_local_vars) add_called_macros calls macro_defs_and_pi = foldSt add_called_macro calls macro_defs_and_pi @@ -1013,16 +1054,17 @@ mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos}), case mergeCases expr_and_pos _ var_heap symbol_heap error = (expr_and_pos, var_heap, symbol_heap, checkWarning "" " alternative will never match" error) - -liftFunctions min_level group group_index fun_defs var_heap expr_heap +liftFunctions min_level group group_index main_dcl_module_n fun_defs var_heap expr_heap # (contains_free_vars, lifted_function_called, fun_defs) = foldSt (add_free_vars_of_non_recursive_calls_to_function group_index) group (False, False, fun_defs) | contains_free_vars # fun_defs = iterateSt (add_free_vars_of_recursive_calls_to_functions group_index group) fun_defs - = lift_functions group fun_defs var_heap expr_heap +// = lift_functions group fun_defs var_heap expr_heap + = lift_functions group {ls_x={x_fun_defs=fun_defs,x_main_dcl_module_n=main_dcl_module_n},ls_var_heap=var_heap,ls_expr_heap=expr_heap} | lifted_function_called - = lift_functions group fun_defs var_heap expr_heap - = (fun_defs, var_heap, expr_heap) + = lift_functions group {ls_x={x_fun_defs=fun_defs,x_main_dcl_module_n=main_dcl_module_n},ls_var_heap=var_heap,ls_expr_heap=expr_heap} +// = (fun_defs, var_heap, expr_heap) + = {ls_x={x_fun_defs=fun_defs,x_main_dcl_module_n=main_dcl_module_n},ls_var_heap=var_heap, ls_expr_heap=expr_heap} where add_free_vars_of_non_recursive_calls_to_function group_index fun (contains_free_vars, lifted_function_called, fun_defs) @@ -1077,18 +1119,24 @@ where # (free_var_added, free_vars) = newFreeVariable var free_vars = add_free_global_variables vars (free_var_added || free_vars_added, free_vars) - lift_functions group fun_defs var_heap expr_heap - = foldSt lift_function group (fun_defs, var_heap, expr_heap) +// lift_functions group fun_defs var_heap expr_heap +// = foldSt lift_function group (fun_defs, var_heap, expr_heap) + lift_functions group lift_state + = foldSt lift_function group lift_state where - lift_function fun (fun_defs=:{[fun] = fun_def}, var_heap, expr_heap) +// lift_function fun (fun_defs=:{[fun] = fun_def}, var_heap, expr_heap) + lift_function fun {ls_x=ls_x=:{x_fun_defs=fun_defs=:{[fun] = fun_def}}, ls_var_heap=var_heap, ls_expr_heap=expr_heap} # {fi_free_vars} = fun_def.fun_info fun_lifted = length fi_free_vars (PartioningFunction {cb_args,cb_rhs} fun_number) = fun_def.fun_body (cb_args, var_heap) = add_lifted_args fi_free_vars cb_args var_heap - (cb_rhs, {ls_fun_defs,ls_var_heap,ls_expr_heap}) = lift cb_rhs { ls_fun_defs = fun_defs, ls_var_heap = var_heap, ls_expr_heap = expr_heap } +// (cb_rhs, {ls_fun_defs,ls_var_heap,ls_expr_heap}) = lift cb_rhs { ls_fun_defs = fun_defs, ls_var_heap = var_heap, ls_expr_heap = expr_heap } + (cb_rhs, {ls_x,ls_var_heap,ls_expr_heap}) = lift cb_rhs { ls_x={ls_x & x_fun_defs = fun_defs}, ls_var_heap = var_heap, ls_expr_heap = expr_heap } ls_var_heap = remove_lifted_args fi_free_vars ls_var_heap + ls_fun_defs = ls_x.x_fun_defs ls_fun_defs = { ls_fun_defs & [fun] = { fun_def & fun_lifted = fun_lifted, fun_body = PartioningFunction {cb_args = cb_args, cb_rhs = cb_rhs} fun_number}} - = (ls_fun_defs, ls_var_heap, ls_expr_heap) +// = (ls_fun_defs, ls_var_heap, ls_expr_heap) + = {ls_x={ls_x & x_fun_defs=ls_fun_defs}, ls_var_heap=ls_var_heap, ls_expr_heap= ls_expr_heap} // ---> ("lift_function", fun_def.fun_symb, fi_free_vars, cb_args, cb_rhs) remove_lifted_args vars var_heap diff --git a/frontend/type.dcl b/frontend/type.dcl index 8366dc5..40a2352 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -3,9 +3,5 @@ definition module type import StdArray import syntax, check -/* MW4 was: -typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File - -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) -*/ -typeProgram ::!{! Group} !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File +typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !ModuleNumberSet !*Heaps !*PredefinedSymbols !*File !*File -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File) diff --git a/frontend/type.icl b/frontend/type.icl index 333694f..e500538 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1,13 +1,13 @@ implementation module type - import StdEnv import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor import RWSDebug :: TypeInput = - { ti_common_defs :: {# CommonDefs } - , ti_functions :: {# {# FunType }} + { ti_common_defs :: !{# CommonDefs } + , ti_functions :: !{# {# FunType }} + , ti_main_dcl_module_n :: !Int } :: TypeState = @@ -54,9 +54,9 @@ import RWSDebug instance toString BoundVar where toString varid = varid.var_name.id_name - -class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) +class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) +/* instance arraySubst AType where arraySubst atype=:{at_type} subst @@ -119,13 +119,13 @@ where # (tc_types, subst) = arraySubst tc_types subst = ({ tc & tc_types = tc_types}, subst) -/* -instance arraySubst OverloadedCall -where - arraySubst oc=:{oc_context} subst - # (oc_context, subst) = arraySubst oc_context subst - = ({ oc & oc_context = oc_context }, subst) -*/ + /* + instance arraySubst OverloadedCall + where + arraySubst oc=:{oc_context} subst + # (oc_context, subst) = arraySubst oc_context subst + = ({ oc & oc_context = oc_context }, subst) + */ instance arraySubst CaseType where @@ -135,6 +135,240 @@ where (ct_cons_types, subst) = arraySubst ct_cons_types subst = ({ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) +*/ + +instance arraySubst AType +where + arraySubst atype=:{at_type} subst + # (changed,at_type, subst) = arraySubst2 at_type subst + | changed + = ({ atype & at_type = at_type }, subst) + = (atype, subst) + +instance arraySubst Type +where + arraySubst tv=:(TempV tv_number) subst + #! type = subst.[tv_number] + = case type of + TE -> (tv, subst) + _ -> arraySubst type subst + arraySubst type=:(arg_type0 --> res_type0) subst + # (changed,arg_type, subst) = arraySubst2 arg_type0 subst + | changed + # (changed,res_type, subst) = arraySubst2 res_type0 subst + | changed + = (arg_type --> res_type, subst) + = (arg_type --> res_type0, subst) + # (changed,res_type, subst) = arraySubst2 res_type0 subst + | changed + = (arg_type0 --> res_type, subst) + = (type, subst) + arraySubst type=:(TA cons_id cons_args) subst + # (changed,cons_args, subst) = arraySubst2 cons_args subst + | changed + = (TA cons_id cons_args, subst) + = (type, subst) + arraySubst tcv=:(TempCV tv_number :@: types) subst + #! type = subst.[tv_number] + = case type of + TE + # (changed,types, subst) = arraySubst2 types subst + | changed + -> (TempCV tv_number :@: types, subst) + -> (tcv, subst) + _ + # (type, subst) = arraySubst type subst + (types, subst) = arraySubst types subst + -> (simplify_type_appl type types, subst) + where + simplify_type_appl :: !Type ![AType] -> Type + simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args + = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) + simplify_type_appl (cons_var :@: types) type_args + = cons_var :@: (types ++ type_args) + simplify_type_appl (TempV tv_number) type_args + = TempCV tv_number :@: type_args + simplify_type_appl (TempQV tv_number) type_args + = TempQCV tv_number :@: type_args + arraySubst type subst + = (type, subst) + +instance arraySubst [a] | arraySubst2 a +where + arraySubst [] subst + = ([],subst) + arraySubst t=:[type0:types0] subst + # (changed,types,subst) = arraySubst2 types0 subst + | changed + # (changed,type,subst) = arraySubst2 type0 subst + | changed + = ([type:types],subst) + = ([type0:types],subst) + # (changed,type,subst) = arraySubst2 type0 subst + | changed + = ([type:types0],subst) + = (t,subst) + +instance arraySubst TempSymbolType +where + arraySubst tst=:{tst_args,tst_result,tst_context} subst + # (changed,tst_args, subst) = arraySubst2 tst_args subst + | changed + # (changed,tst_result, subst) = arraySubst2 tst_result subst + # (changed,tst_context, subst) = arraySubst2 tst_context subst + = ({tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) + # (changed,tst_result, subst) = arraySubst2 tst_result subst + | changed + # (changed,tst_context, subst) = arraySubst2 tst_context subst + = ({tst & tst_result = tst_result,tst_context = tst_context}, subst) + # (changed,tst_context, subst) = arraySubst2 tst_context subst + | changed + = ({tst & tst_context = tst_context}, subst) + = (tst, subst) + +instance arraySubst TypeContext +where + arraySubst tc=:{tc_types} subst + # (changed,tc_types, subst) = arraySubst2 tc_types subst + | changed + = ({ tc & tc_types = tc_types}, subst) + = ( tc, subst) + +instance arraySubst CaseType +where + arraySubst ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst + # (changed,ct_pattern_type, subst) = arraySubst2 ct_pattern_type subst + | changed + # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + = ({ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) + # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst + | changed + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + = ({ ct & ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + | changed + = ({ ct & ct_cons_types = ct_cons_types }, subst) + = (ct, subst) + +class arraySubst2 type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type}) + +instance arraySubst2 AType +where + arraySubst2 atype=:{at_type} subst + # (changed,at_type, subst) = arraySubst2 at_type subst + | changed + = (True,{ atype & at_type = at_type }, subst) + = (False,atype, subst) + +instance arraySubst2 Type +where + arraySubst2 tv=:(TempV tv_number) subst + #! type = subst.[tv_number] + = case type of + TE -> (False,tv, subst) + _ + # (t,s) = arraySubst type subst + -> (True,t,s) + arraySubst2 type=:(arg_type0 --> res_type0) subst + # (changed,arg_type, subst) = arraySubst2 arg_type0 subst + | changed + # (changed,res_type, subst) = arraySubst2 res_type0 subst + | changed + = (True,arg_type --> res_type, subst) + = (True,arg_type --> res_type0, subst) + # (changed,res_type, subst) = arraySubst2 res_type0 subst + | changed + = (True,arg_type0 --> res_type, subst) + = (False,type, subst) + arraySubst2 type=:(TA cons_id cons_args) subst + # (changed,cons_args, subst) = arraySubst2 cons_args subst + | changed + = (True,TA cons_id cons_args, subst) + = (False,type, subst) + arraySubst2 tcv=:(TempCV tv_number :@: types) subst + #! type = subst.[tv_number] + = case type of + TE + # (changed,types, subst) = arraySubst2 types subst + | changed + -> (True,TempCV tv_number :@: types, subst) + -> (False,tcv, subst) + _ + # (type, subst) = arraySubst type subst + (types, subst) = arraySubst types subst + -> (True,simplify_type_appl type types, subst) + where + simplify_type_appl :: !Type ![AType] -> Type + simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args + = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) + simplify_type_appl (cons_var :@: types) type_args + = cons_var :@: (types ++ type_args) + simplify_type_appl (TempV tv_number) type_args + = TempCV tv_number :@: type_args + simplify_type_appl (TempQV tv_number) type_args + = TempQCV tv_number :@: type_args + arraySubst2 type subst + = (False,type, subst) + +instance arraySubst2 [a] | arraySubst2 a +where + arraySubst2 [] subst + = (False,[],subst) + arraySubst2 t=:[type0:types0] subst + # (changed,types,subst) = arraySubst2 types0 subst + | changed + # (changed,type,subst) = arraySubst2 type0 subst + | changed + = (True,[type:types],subst) + = (True,[type0:types],subst) + # (changed,type,subst) = arraySubst2 type0 subst + | changed + = (True,[type:types0],subst) + = (False,t,subst) + +instance arraySubst2 TempSymbolType +where + arraySubst2 tst=:{tst_args,tst_result,tst_context} subst + # (changed,tst_args, subst) = arraySubst2 tst_args subst + | changed + # (changed,tst_result, subst) = arraySubst2 tst_result subst + # (changed,tst_context, subst) = arraySubst2 tst_context subst + = (True,{tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) + # (changed,tst_result, subst) = arraySubst2 tst_result subst + | changed + # (changed,tst_context, subst) = arraySubst2 tst_context subst + = (True,{tst & tst_result = tst_result,tst_context = tst_context}, subst) + # (changed,tst_context, subst) = arraySubst2 tst_context subst + | changed + = (True,{tst & tst_context = tst_context}, subst) + = (False,tst, subst) + +instance arraySubst2 TypeContext +where + arraySubst2 tc=:{tc_types} subst + # (changed,tc_types, subst) = arraySubst2 tc_types subst + | changed + = (True,{ tc & tc_types = tc_types}, subst) + = (False, tc, subst) + +instance arraySubst2 CaseType +where + arraySubst2 ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst + # (changed,ct_pattern_type, subst) = arraySubst2 ct_pattern_type subst + | changed + # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + = (True,{ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) + # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst + | changed + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + = (True,{ ct & ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) + # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst + | changed + = (True,{ ct & ct_cons_types = ct_cons_types }, subst) + = (False,ct, subst) + class contains_var a :: !Int !a -> Bool instance contains_var [a] | contains_var a @@ -262,7 +496,8 @@ where = unify t1x t2x modules subst heaps = (False, subst, heaps) -instance unify [a] | unify, arraySubst a +//instance unify [a] | unify, arraySubst a +instance unify [a] | unify, arraySubst, arraySubst2 a where unify [t1 : ts1] [t2 : ts2] modules subst heaps = unify (t1,ts1) (t2,ts2) modules subst heaps @@ -564,9 +799,12 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_ { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps, ts_var_heap = ts_var_heap}) // ---> ("freshSymbolType", tst_args, tst_result, tst_context) where + fresh_type_variables :: .[TypeVar] *(*Heap TypeVarInfo,.Int) -> (!.Heap TypeVarInfo,!Int); fresh_type_variables type_variables state = foldr (\{tv_info_ptr} (var_heap, var_store) -> (writePtr tv_info_ptr (TVI_Type (TempV var_store)) var_heap, inc var_store)) state type_variables + + fresh_attributes :: .[AttributeVar] *(*Heap AttrVarInfo,.Int) -> (!.Heap AttrVarInfo,!Int); fresh_attributes attributes state = foldr (\{av_info_ptr} (attr_heap, attr_store) -> (writePtr av_info_ptr (AVI_Attr (TA_TempVar attr_store)) attr_heap, inc attr_store)) state attributes @@ -654,7 +892,9 @@ attribute_error type_attr err # err = errorHeading "Type error" err = { err & ea_file = err.ea_file <<< "* attribute expected instead of " <<< type_attr <<< '\n' } -addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module}} cons_args, at_attribute} ps +addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState); +//addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module}} cons_args, at_attribute} ps +addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index={glob_object,glob_module},type_name} cons_args, at_attribute} ps # (cons_args, props, ps=:{prop_td_infos,prop_type_heaps,prop_attr_vars,prop_attr_env,prop_error}) = add_propagation_attributes_to_atypes modules cons_args ps (prop_class, th_vars, prop_td_infos) = propClassification glob_object glob_module props modules prop_type_heaps.th_vars prop_td_infos @@ -847,8 +1087,11 @@ storeAttribute (Yes expt_ptr) type_attribute symbol_heap storeAttribute No type_attribute symbol_heap = symbol_heap -getSymbolType ti=:{ti_functions,ti_common_defs} {symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name} ts - | glob_module == cIclModIndex +getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name} ts +// | glob_module == cIclModIndex + | glob_module == ti_main_dcl_module_n + | glob_object>=size ts.ts_fun_env + = abort symb_name.id_name; # (fun_type, ts) = ts!ts_fun_env.[glob_object] = case fun_type of UncheckedType fun_type @@ -864,9 +1107,11 @@ getSymbolType ti=:{ti_functions,ti_common_defs} {symb_kind = SK_Function {glob_m (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts -> (fun_type_copy, cons_variables, [], ts) _ - -> abort "getSymbolType (type.icl)" ---> (symb_name, fun_type) + -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) # {ft_type,ft_type_ptr,ft_specials} = ti_functions.[glob_module].[glob_object] - (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction symb_name symb_arity ft_type ft_type_ptr ti_common_defs ts + | glob_module>=size ti_functions || glob_object>=size ti_functions.[glob_module] + = abort (toString glob_module+++" "+++toString glob_object+++" "+++toString ti_main_dcl_module_n+++" "+++symb_name.id_name); + # (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction symb_name symb_arity ft_type ft_type_ptr ti_common_defs ts = (fun_type_copy, cons_variables, get_specials ft_specials, ts) where get_specials (SP_ContextTypes specials) = specials @@ -874,6 +1119,25 @@ getSymbolType ti=:{ti_functions,ti_common_defs} {symb_kind = SK_Function {glob_m getSymbolType ti {symb_kind = SK_Constructor {glob_module,glob_object}, symb_arity} ts # (fresh_cons_type, ts) = standardRhsConstructorType glob_object glob_module symb_arity ti ts = (fresh_cons_type, [], [], ts) +getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_arity, symb_name} ts + | glob_object>=size ts.ts_fun_env + = abort symb_name.id_name; + # (fun_type, ts) = ts!ts_fun_env.[glob_object] + = case fun_type of + UncheckedType fun_type + # (fun_type_copy, ts) = currySymbolType fun_type symb_arity ts + -> (fun_type_copy, [], [], ts) + SpecifiedType fun_type lifted_arg_types _ + # (fun_type_copy=:{tst_args,tst_arity}, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars fun_type ti_common_defs ts + (fun_type_copy, ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args, + tst_arity = tst_arity + length lifted_arg_types } symb_arity ts + -> (fun_type_copy, cons_variables, [], ts) + CheckedType fun_type + # (fun_type_copy, cons_variables, ts) = freshSymbolType cWithFreshContextVars fun_type ti_common_defs ts + (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts + -> (fun_type_copy, cons_variables, [], ts) + _ + -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) getSymbolType ti=:{ti_common_defs} {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} ts # {me_symb, me_type,me_type_ptr} = ti_common_defs.[glob_module].com_member_defs.[glob_object] (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction me_symb symb_arity me_type me_type_ptr ti_common_defs ts @@ -1610,30 +1874,26 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con , fe_location :: !IdentPos } -// MW4 was:typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File -typeProgram ::!{! Group} !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File !*File -// MW4 was: -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) +typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !ModuleNumberSet !*Heaps !*PredefinedSymbols !*File !*File -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File, !*File) -// MW4 was:typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file -typeProgram comps fun_defs specials list_inferred_types icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out +typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } - ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [cIclModIndex] = icl_defs } + ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [main_dcl_module_n] = icl_defs } ti_functions = {dcl_functions \\ {dcl_functions} <-: modules } type_def_sizes = [ size com_type_defs \\ {com_type_defs} <-: ti_common_defs ] class_def_sizes = [ size com_class_defs \\ {com_class_defs} <-: ti_common_defs ] class_instances = { { IT_Empty \\ i <- [0 .. dec size] } \\ size <- class_def_sizes } - (td_infos, hp_type_heaps, ts_error) = analTypeDefs ti_common_defs hp_type_heaps ts_error + (td_infos, hp_type_heaps, ts_error) = analTypeDefs ti_common_defs used_module_numbers hp_type_heaps ts_error state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos (_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, -// MW4 was: ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error } ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_out = out } - ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions } + ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n } special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] } // MW4 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) = type_components list_inferred_types 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) @@ -1647,7 +1907,6 @@ typeProgram comps fun_defs specials list_inferred_types icl_defs imports modules (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, -// MW4 was: {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file) {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file, ts_out) // ---> ("typeProgram", array_inst_types) where @@ -1660,7 +1919,8 @@ where = state collect_and_check_instances nr_of_instances common_defs state - = iFoldSt (update_instances_of_class common_defs cIclModIndex) 0 nr_of_instances state +// = iFoldSt (update_instances_of_class common_defs cIclModIndex) 0 nr_of_instances state + = iFoldSt (update_instances_of_class common_defs main_dcl_module_n) 0 nr_of_instances state update_instances_of_class common_defs mod_index ins_index (dummy, error, class_instances, type_var_heap, td_infos) # {ins_class={glob_object={ds_index},glob_module},ins_type={it_types}} = common_defs.[mod_index].com_instance_defs.[ins_index] @@ -1749,7 +2009,8 @@ where 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 <> NoIndex && pds_module == cIclModIndex + | pds_def <> NoIndex && pds_module == main_dcl_module_n = (pds_def, predef_symbols) = (NoIndex, predef_symbols) @@ -1773,7 +2034,7 @@ where (over_info, (subst, ts_expr_heap)) = collect_and_expand_overloaded_calls fun_reqs [] (subst, ts_expr_heap) (contexts, coercion_env, local_pattern_variables, dict_types, { os_type_heaps, os_var_heap, os_symbol_heap, os_predef_symbols, os_special_instances, os_error }) - = tryToSolveOverloading over_info ti_common_defs class_instances coercion_env + = tryToSolveOverloading over_info main_dcl_module_n ti_common_defs class_instances coercion_env { os_type_heaps = {ts_type_heaps & th_vars = th_vars}, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap, os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } | not os_error.ea_ok @@ -1800,7 +2061,7 @@ where type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, tci_type_var_heap = ts_type_heaps.th_vars } (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols) - = updateDynamics comp local_pattern_variables fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols + = updateDynamics comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, @@ -1809,7 +2070,7 @@ where type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, tci_type_var_heap = ts_type_heaps.th_vars } (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols) - = removeOverloadedFunctions comp local_pattern_variables fun_defs ts.ts_fun_env + = removeOverloadedFunctions comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, @@ -1868,15 +2129,7 @@ where (prev_vect, bitvects) = bitvects![bit_index] = { bitvects & [bit_index] = prev_vect bitor (1 << BITNUMBER var_number) } -/* MW4 was - build_coercion_env [{fe_requirements={req_type_coercions},fe_location} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error - # error = setErrorAdmin fe_location error - (subst, coercion_env, type_signs, type_var_heap, error) - = add_to_coercion_env req_type_coercions subst coercion_env common_defs cons_var_vects type_signs type_var_heap error - = build_coercion_env reqs_list subst coercion_env common_defs cons_var_vects type_signs type_var_heap error - build_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error - = (subst, coercion_env, type_signs, type_var_heap, error) -*/ + build_coercion_env :: [.FunctionRequirements] v:{!Type} *Coercions {#CommonDefs} {#Int} *{#*{#TypeDefInfo}} *TypeHeaps !*ErrorAdmin -> (!w:{!Type},!.Coercions,!u:{#u:{#TypeDefInfo}},!.TypeHeaps,!.ErrorAdmin), [v <= w]; build_coercion_env [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error # (subst, coercion_env, type_signs, type_var_heap, error) = foldSt (build_coercion_env_for_alternative ip_ident common_defs cons_var_vects) diff --git a/frontend/unitype.icl b/frontend/unitype.icl index 14c38ce..046a8c0 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -29,7 +29,7 @@ FirstAttrVar :== 3 :: PartitioningInfo = { pi_marks :: !.AttributePartition , pi_next_num :: !Int - , pi_groups :: ![[Int]] + , pi_groups :: !.[[Int]] , pi_deps :: ![Int] } @@ -86,6 +86,14 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions ---> ("determineAttributeCoercions", exp_off_type, exp_dem_type) -> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error) -> undef + +file_to_true :: !File -> Bool +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + } */ @@ -114,8 +122,8 @@ where = visit_attributes right max_attr_nr min_dep coer_offered pi visit_attributes tree max_attr_nr min_dep coer_offered pi = (min_dep, pi) - - reverse_and_length :: ![a] !Int ![a] -> (!Int, ![a]) + + reverse_and_length :: !*[a] !Int ![a] -> (!Int, ![a]) reverse_and_length [] length list = (length, list) reverse_and_length [ x : xs ] length list = reverse_and_length xs (inc length) [x : list] @@ -237,9 +245,9 @@ liftTempTypeVariable modules cons_vars tv_number subst ls TE -> (TempV tv_number, subst, ls) _ -> lift modules cons_vars type subst ls -class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState - -> (!a, !*{! Type}, !*LiftState) +class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!a, !*{! Type}, !*LiftState) +/* instance lift Type where lift modules cons_vars (TempV tv_number) subst ls @@ -248,11 +256,14 @@ where # (arg_type, subst, ls) = lift modules cons_vars arg_type subst ls (res_type, subst, ls) = lift modules cons_vars res_type subst ls = (arg_type --> res_type, subst, ls) - lift modules cons_vars (TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity} cons_args) subst ls +// lift modules cons_vars (TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity} cons_args) subst ls + lift modules cons_vars (TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos - = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + | equal_type_prop type_prop type_prop0 + = (TA cons_id cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) where lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState -> (![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) @@ -314,6 +325,237 @@ where = True type_is_non_coercible _ = False +*/ +instance lift Type +where + lift modules cons_vars t=:(TempV tv_number) subst ls + #! type = subst.[tv_number] + = case type of + TE -> (t,subst, ls) + _ -> lift modules cons_vars type subst ls + lift modules cons_vars t=:(arg_type0 --> res_type0) subst ls + # (changed,arg_type, subst, ls) = lift2 modules cons_vars arg_type0 subst ls + | changed + # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + | changed + = (arg_type --> res_type, subst, ls) + = (arg_type --> res_type0, subst, ls) + # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + | changed + = (arg_type0 --> res_type, subst, ls) + = (t,subst, ls) + lift modules cons_vars t0=:(TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls + # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] + # (changed,cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls + | changed + # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos + | equal_type_prop type_prop type_prop0 + = (TA cons_id cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos + | equal_type_prop type_prop type_prop0 + = (t0, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + where + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState + -> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) + lift_list modules cons_vars [] _ subst ls + = (False,[], [], [], subst, ls) + lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls + # (changed,t,subst, ls) = lift2 modules cons_vars t0 subst ls + | changed + # (_,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + # (changed,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | changed + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True,[t0:ts], sign_classes,prop_classes, subst, ls) + = (True,[t:ts], sign_classes, prop_classes, subst, ls) + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (False,ts0, sign_classes, prop_classes, subst, ls) + = (False,ts0, sign_classes, prop_classes, subst, ls) + + add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes + = ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) + add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes + | isPositive tmp_var_id cons_vars + = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) + = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) + add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes + = ([TopSignClass : sign_classes], [PropClass : prop_classes]) + lift modules cons_vars (TempCV temp_var :@: types) subst ls + # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls + (_,types, subst, ls) = lift_list modules cons_vars types subst ls + = case type of + TA type_cons cons_args + # nr_of_new_args = length types + -> (TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), subst, ls) + TempV tv_number + -> (TempCV tv_number :@: types, subst, ls) + cons_var :@: cv_types + -> (cons_var :@: (cv_types ++ types), subst, ls) + where + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift2 a + lift_list modules cons_vars [] subst ls + = (False,[], subst, ls) + lift_list modules cons_vars ts0=:[t0:ts] subst ls + # (changed,t, subst, ls) = lift2 modules cons_vars t0 subst ls + | changed + # (_,ts, subst, ls) = lift_list modules cons_vars ts subst ls + = (True,[t:ts], subst, ls) + # (changed,ts, subst, ls) = lift_list modules cons_vars ts subst ls + | changed + = (True,[t0:ts], subst, ls) + = (False,ts0, subst, ls) + lift modules cons_vars type subst ls + = (type, subst, ls) + +instance lift AType +where + lift modules cons_vars attr_type=:{at_attribute,at_type} subst ls + # (changed,at_type, subst, ls) = lift2 modules cons_vars at_type subst ls + | changed + | type_is_non_coercible at_type + = ({attr_type & at_type = at_type },subst, ls) + = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + | type_is_non_coercible at_type + = (attr_type,subst, ls) + = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + where + type_is_non_coercible (TempV _) + = True + type_is_non_coercible (TempQV _) + = True + type_is_non_coercible (_ --> _) + = True + type_is_non_coercible (_ :@: _) + = True + type_is_non_coercible _ + = False + +class lift2 a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!Bool,!a, !*{! Type}, !*LiftState) + +instance lift2 Type +where + lift2 modules cons_vars t=:(TempV tv_number) subst ls + #! type = subst.[tv_number] + = case type of + TE -> (lift2_False,t,subst, ls) + _ # (type,subst, ls) =lift modules cons_vars type subst ls + -> (lift2_True,type,subst, ls) + lift2 modules cons_vars t=:(arg_type0 --> res_type0) subst ls + # (changed,arg_type, subst, ls) = lift2 modules cons_vars arg_type0 subst ls + | changed + # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + | changed + = (lift2_True,arg_type --> res_type, subst, ls) + = (lift2_True,arg_type --> res_type0, subst, ls) + # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + | changed + = (lift2_True,arg_type0 --> res_type, subst, ls) + = (lift2_False,t,subst, ls) + lift2 modules cons_vars t0=:(TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls + # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] + # (changed,cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls + | changed + # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos + | equal_type_prop type_prop type_prop0 + = (lift2_True,TA cons_id cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (lift2_True,TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos + | equal_type_prop type_prop type_prop0 + = (lift2_False,t0, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (lift2_True,TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + where + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState + -> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) + lift_list modules cons_vars [] _ subst ls + = (False,[], [], [], subst, ls) + lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls + # (changed,t,subst, ls) = lift2 modules cons_vars t0 subst ls + | changed + # (_,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + # (changed,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | changed + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True,[t0:ts], sign_classes,prop_classes, subst, ls) + = (True,[t:ts], sign_classes, prop_classes, subst, ls) + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (False,ts0, sign_classes, prop_classes, subst, ls) + = (False,ts0, sign_classes, prop_classes, subst, ls) + + add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes + = ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) + add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes + | isPositive tmp_var_id cons_vars + = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) + = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) + add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes + = ([TopSignClass : sign_classes], [PropClass : prop_classes]) + lift2 modules cons_vars (TempCV temp_var :@: types) subst ls + # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls + (_,types, subst, ls) = lift_list modules cons_vars types subst ls + = case type of + TA type_cons cons_args + # nr_of_new_args = length types + -> (lift2_True,TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), subst, ls) + TempV tv_number + -> (lift2_True,TempCV tv_number :@: types, subst, ls) + cons_var :@: cv_types + -> (lift2_True,cons_var :@: (cv_types ++ types), subst, ls) + where + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift2 a + lift_list modules cons_vars [] subst ls + = (False,[], subst, ls) + lift_list modules cons_vars ts0=:[t0:ts] subst ls + # (changed,t, subst, ls) = lift2 modules cons_vars t0 subst ls + | changed + # (_,ts, subst, ls) = lift_list modules cons_vars ts subst ls + = (True,[t:ts], subst, ls) + # (changed,ts, subst, ls) = lift_list modules cons_vars ts subst ls + | changed + = (True,[t0:ts], subst, ls) + = (False,ts0, subst, ls) + lift2 modules cons_vars type subst ls + = (lift2_False,type, subst, ls) + +lift2_True :== True +lift2_False :== False + +instance lift2 AType +where + lift2 modules cons_vars attr_type=:{at_attribute,at_type} subst ls + # (changed,at_type, subst, ls) = lift2 modules cons_vars at_type subst ls + | changed + | type_is_non_coercible at_type + = (True,{attr_type & at_type = at_type },subst, ls) + = (True,{attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + | type_is_non_coercible at_type + = (False,attr_type,subst, ls) + = (True,{attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + where + type_is_non_coercible (TempV _) + = True + type_is_non_coercible (TempQV _) + = True + type_is_non_coercible (_ --> _) + = True + type_is_non_coercible (_ :@: _) + = True + type_is_non_coercible _ + = False + :: ExpansionState = @@ -322,7 +564,7 @@ where } class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) - +/* instance expandType AType where expandType modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) @@ -338,6 +580,52 @@ where -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) expand_attribute attr attr_var_heap = (attr, attr_var_heap) +*/ +instance expandType AType +where + expandType modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) + # (changed,at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs + | changed + # (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + = ({ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) + # (changed,at_type, subst_and_es) = expandType2 modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + | changed + = ({ attr_type & at_type = at_type }, subst_and_es) + = (attr_type, subst_and_es) + where + expand_attribute :: TypeAttribute *(Heap AttrVarInfo) -> (!.Bool,TypeAttribute,!.Heap AttrVarInfo); + expand_attribute (TA_Var {av_name,av_info_ptr}) attr_var_heap + = case (readPtr av_info_ptr attr_var_heap) of + (AVI_Attr attr, attr_var_heap) + -> (True,attr, attr_var_heap) + (info, attr_var_heap) + -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) + expand_attribute attr attr_var_heap + = (False,attr, attr_var_heap) + +class expandType2 a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool,!a, !*(!u:{! Type}, !*ExpansionState)) + +instance expandType2 AType +where + expandType2 modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) + # (changed,at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs + | changed + # (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + = (True,{ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) + # (changed,at_type, subst_and_es) = expandType2 modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + | changed + = (True,{ attr_type & at_type = at_type }, subst_and_es) + = (False,attr_type, subst_and_es) + where + expand_attribute :: TypeAttribute *(Heap AttrVarInfo) -> (!.Bool,TypeAttribute,!.Heap AttrVarInfo); + expand_attribute (TA_Var {av_name,av_info_ptr}) attr_var_heap + = case (readPtr av_info_ptr attr_var_heap) of + (AVI_Attr attr, attr_var_heap) + -> (True,attr, attr_var_heap) + (info, attr_var_heap) + -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) + expand_attribute attr attr_var_heap + = (False,attr, attr_var_heap) expandTempTypeVariable :: !TempVarId !*(!u:{! Type}, !*ExpansionState) -> (!Type, !*(!u:{! Type}, !*ExpansionState)) expandTempTypeVariable tv_number (subst, es) @@ -349,6 +637,10 @@ expandTempTypeVariable tv_number (subst, es) IsArrowKind (KindArrow _) = True IsArrowKind _ = False +equal_type_prop {tsp_sign=sign0,tsp_propagation=prop0,tsp_coercible=coerc0} {tsp_sign=sign1,tsp_propagation=prop1,tsp_coercible=coerc1} + = prop0==prop1 && coerc0==coerc1 && sign0.sc_pos_vect==sign1.sc_pos_vect && sign0.sc_neg_vect==sign1.sc_neg_vect + +/* instance expandType Type where expandType modules cons_vars (TempV tv_number) es @@ -360,13 +652,17 @@ where # (arg_type, es) = expandType modules cons_vars arg_type es (res_type, es) = expandType modules cons_vars res_type es = (arg_type --> res_type, es) - expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module}} cons_args) (subst, es) +// expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module}} cons_args) (subst, es) + expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] (cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos - = (TA { cons_id & type_prop = type_prop } cons_args, + | equal_type_prop type_prop type_prop0 + = (TA cons_id cons_args, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) // ---> ("expandType", type_name, type_prop.tsp_propagation) where expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) @@ -406,6 +702,207 @@ where instance expandType [a] | expandType a where expandType modules cons_vars l es = mapSt (expandType modules cons_vars) l es +*/ + +instance expandType Type +where + expandType modules cons_vars t0=:(TempV tv_number) est=:(subst,es) + #! type = subst.[tv_number] + = case type of + TE -> (t0, est) + _ -> (type, est) + expandType modules cons_vars (TV {tv_info_ptr}) (subst, es=:{es_type_heaps}) + # (TVI_Type type, th_vars) = readPtr tv_info_ptr es_type_heaps.th_vars + = (type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + expandType modules cons_vars t0=:(arg_type0 --> res_type0) es + # (changed,arg_type, es) = expandType2 modules cons_vars arg_type0 es + | changed + # (res_type, es) = expandType modules cons_vars res_type0 es + = (arg_type --> res_type, es) + # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es + | changed + = (arg_type0 --> res_type, es) + = (t0, es) + expandType modules cons_vars t0=:(TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) + # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] + (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) + | changed + # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos + | equal_type_prop type_prop type_prop0 + = (TA cons_id cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + // ---> ("expandType", type_name, type_prop.tsp_propagation) + # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos + | equal_type_prop type_prop type_prop0 + = (t0, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + // ---> ("expandType", type_name, type_prop.tsp_propagation) + where + expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) + -> (!Bool,![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState)) + expand_type_list modules cons_vars [] _ es + = (False,[], [], [], es) + expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es + # (changed,t, es) = expandType2 modules cons_vars t0 es + | changed + # (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (True,[t:ts], sign_classes, prop_classes, es) + = (True,[t:ts], sign_classes, prop_classes, es) + # (changed,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es + | changed + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (True,[t0:ts], sign_classes, prop_classes, es) + = (True,[t0:ts], sign_classes, prop_classes, es) + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (False,ts0, sign_classes, prop_classes, es) + = (False,ts0, sign_classes, prop_classes, es) + + add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes + =([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) + add_sign_and_prop_of_arrow_kind ( TempV tmp_var_id) sign_classes prop_classes + | isPositive tmp_var_id cons_vars + = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) + = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) + add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes + = ([TopSignClass : sign_classes], [PropClass : prop_classes]) + + expandType modules cons_vars (TempCV temp_var :@: types) es + # (type, es) = expandTempTypeVariable temp_var es + (types, es) = expandType modules cons_vars types es + = case type of + TA type_cons=:{type_arity} cons_args + # nr_of_new_args = length types + -> (TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) + TempV tv_number + -> (TempCV tv_number :@: types, es) + cons_var :@: cv_types + -> (cons_var :@: (cv_types ++ types), es) + expandType modules cons_vars type es + = (type, es) + +instance expandType [a] | expandType,expandType2 a +where + expandType modules cons_vars [] es + = ([],es) + expandType modules cons_vars types0=:[type0:types] es + # (changed,type,es) = expandType2 modules cons_vars type0 es + | changed + # (types,es) = expandType modules cons_vars types es + = ([type:types],es) + # (changed,types,es) = expandType2 modules cons_vars types es + | changed + = ([type0:types],es) + = (types0,es) + +instance expandType2 Type +where + expandType2 modules cons_vars t0=:(TempV tv_number) est=:(subst,es) + #! type = subst.[tv_number] + = case type of + TE -> (False,t0, est) + _ -> (True,type, est) + expandType2 modules cons_vars (TV {tv_info_ptr}) (subst, es=:{es_type_heaps}) + # (TVI_Type type, th_vars) = readPtr tv_info_ptr es_type_heaps.th_vars + = (True,type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + expandType2 modules cons_vars t0=:(arg_type0 --> res_type0) es + # (changed,arg_type, es) = expandType2 modules cons_vars arg_type0 es + | changed + # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es + | changed + = (AexpandType2_True,arg_type --> res_type, es) + = (AexpandType2_True,arg_type --> res_type0, es) + # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es + | changed + = (AexpandType2_True,arg_type0 --> res_type, es) + = (AexpandType2_False,t0, es) + expandType2 modules cons_vars t0=:(TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) + # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] + (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) + | changed + # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos + | equal_type_prop type_prop type_prop0 + = (AexpandType2_True,TA cons_id cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (AexpandType2_True,TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos + | equal_type_prop type_prop type_prop0 + = (AexpandType2_False,t0, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (AexpandType2_True,TA { cons_id & type_prop = type_prop } cons_args, + (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + where + expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) + -> (!Bool,![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState)) + expand_type_list modules cons_vars [] _ es + = (False,[], [], [], es) + expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es + # (changed,t, es) = expandType2 modules cons_vars t0 es + | changed + # (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (True,[t:ts], sign_classes, prop_classes, es) + = (True,[t:ts], sign_classes, prop_classes, es) + # (changed,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es + | changed + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (True,[t0:ts], sign_classes, prop_classes, es) + = (True,[t0:ts], sign_classes, prop_classes, es) + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; + = (False,ts0, sign_classes, prop_classes, es) + = (False,ts0, sign_classes, prop_classes, es) + + add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes + =([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) + add_sign_and_prop_of_arrow_kind ( TempV tmp_var_id) sign_classes prop_classes + | isPositive tmp_var_id cons_vars + = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) + = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) + add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes + = ([TopSignClass : sign_classes], [PropClass : prop_classes]) + + expandType2 modules cons_vars (TempCV temp_var :@: types) es + # (type, es) = expandTempTypeVariable temp_var es + (types, es) = expandType modules cons_vars types es + = case type of + TA type_cons=:{type_arity} cons_args + # nr_of_new_args = length types + -> (AexpandType2_True,TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) + TempV tv_number + -> (AexpandType2_True,TempCV tv_number :@: types, es) + cons_var :@: cv_types + -> (AexpandType2_True,cons_var :@: (cv_types ++ types), es) + expandType2 modules cons_vars type es + = (False,type, es) + +AexpandType2_False :== False +AexpandType2_True :== True + +instance expandType2 [a] | expandType,expandType2 a +where + expandType2 modules cons_vars [] es + = (False,[],es) + expandType2 modules cons_vars types0=:[type0:types] es + # (changed,type,es) = expandType2 modules cons_vars type0 es + | changed + # (types,es) = expandType modules cons_vars types es + = (True,[type:types],es) + # (changed,types,es) = expandType2 modules cons_vars types es + | changed + = (True,[type0:types],es) + = (False,types0,es) + instance toInt TypeAttribute where @@ -431,6 +928,8 @@ offered_attribute according to sign. Failure is indicated by returning False as */ +coerceAttributes :: !.TypeAttribute !.TypeAttribute !.Sign *Coercions -> (!Bool,.Coercions); + /* Just Temporary */ coerceAttributes TA_TempExVar dem_attr _ coercions @@ -637,6 +1136,7 @@ where adjust_sign sign _ cons_vars = sign + add_propagation_inequalities :: TypeAttribute !Type *Coercions -> (!.Bool,.Coercions); add_propagation_inequalities attr (TA {type_name,type_prop={tsp_propagation}} cons_args) coercions = add_inequalities tsp_propagation attr cons_args coercions where @@ -731,12 +1231,3 @@ where (<<<) file CT_Unique = file <<< "CT_Unique" (<<<) file CT_NonUnique = file <<< "CT_NonUnique" (<<<) file CT_Empty = file <<< "##" - -file_to_true :: !File -> Bool -file_to_true file = code { - .inline file_to_true - pop_b 2 - pushB TRUE - .end - } - |