diff options
| author | martinw | 2000-10-04 15:13:36 +0000 |
|---|---|---|
| committer | martinw | 2000-10-04 15:13:36 +0000 |
| commit | 09ffb02f9a682e8278987e9803817107d4124de4 (patch) | |
| tree | 995f984abf4db9fbae822f7c22f2aa9a4db1f3fc | |
| parent | added new function to print function names like "c;102;13" as "comprehesion [... (diff) | |
-added position information for let bindings for better error messages
(changes are commented with "MW0")
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@248 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
| -rw-r--r-- | backend/backendconvert.icl | 33 | ||||
| -rw-r--r-- | backend/backendpreprocess.icl | 24 | ||||
| -rw-r--r-- | frontend/check.icl | 176 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 14 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 124 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 70 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 6 | ||||
| -rw-r--r-- | frontend/overloading.icl | 39 | ||||
| -rw-r--r-- | frontend/refmark.icl | 22 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 13 | ||||
| -rw-r--r-- | frontend/syntax.icl | 17 | ||||
| -rw-r--r-- | frontend/transform.icl | 68 | ||||
| -rw-r--r-- | frontend/type.icl | 131 |
13 files changed, 484 insertions, 253 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index e998a46..af8e1f8 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -535,13 +535,17 @@ instance declareVars FreeVar where declareVars freeVar (_, varHeap) = declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap -instance declareVars (Bind Expression FreeVar) where - declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> BackEnder - declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap) +// MW0instance declareVars (Bind Expression FreeVar) where +instance declareVars LetBind where +// MW0 declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> BackEnder + declareVars :: LetBind !DeclVarsInput -> BackEnder +// MW0 declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap) + declareVars {lb_src=App {app_symb, app_args=[Var _:_]}, lb_dst=freeVar} (aliasDummyId, varHeap) | app_symb.symb_name==aliasDummyId = identity // we have an alias. Don't declare the same variable twice = declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap - declareVars {bind_dst=freeVar} (_, varHeap) +// MW0 declareVars {bind_dst=freeVar} (_, varHeap) + declareVars {lb_dst=freeVar} (_, varHeap) = declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap declareVariable :: Int (Ptr VarInfo) {#Char} VarHeap -> BackEnder @@ -1244,13 +1248,15 @@ defineLhsNodeDef freeVar pattern nodeDefs varHeap (beNodeDef variable_sequence_number (convertPattern pattern varHeap)) (return nodeDefs) be -collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar] +// MW0 collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar] +collectNodeDefs :: Ident Expression -> [LetBind] collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds}) = filterStrictAlias let_strict_binds let_lazy_binds where filterStrictAlias [] let_lazy_binds = let_lazy_binds - filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds +// MW0 filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds + filterStrictAlias [strict_bind=:{lb_src=App app}:strict_binds] let_lazy_binds | app.app_symb.symb_name==aliasDummyId // the compiled source was a strict alias like "#! x = y" = case hd app.app_args of @@ -1259,7 +1265,8 @@ collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds}) -> filterStrictAlias strict_binds let_lazy_binds hd_app_args // the node is not an alias anymore: remove just the _dummyForStrictAlias call - -> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds] +// MW0 -> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds] + -> [{ strict_bind & lb_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds] filterStrictAlias [strict_bind:strict_binds] let_lazy_binds = [strict_bind: filterStrictAlias strict_binds let_lazy_binds] collectNodeDefs _ _ @@ -1269,18 +1276,22 @@ convertRhsNodeDefs :: Ident Expression Int VarHeap -> BEMonad BENodeDefP convertRhsNodeDefs aliasDummyId expr main_dcl_module_n varHeap = convertNodeDefs (collectNodeDefs aliasDummyId expr) varHeap where - convertNodeDefs :: [Bind Expression FreeVar] VarHeap -> BEMonad BENodeDefP +// MW0 convertNodeDefs :: [Bind Expression FreeVar] VarHeap -> BEMonad BENodeDefP + convertNodeDefs :: [LetBind] VarHeap -> BEMonad BENodeDefP convertNodeDefs binds varHeap = sfoldr (beNodeDefs o flip convertNodeDef varHeap) beNoNodeDefs binds where - convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP - convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap +// MW0 convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP + convertNodeDef :: !LetBind VarHeap -> BEMonad BENodeDefP +// MW0 convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap + convertNodeDef {lb_src=expr, lb_dst=freeVar} varHeap = \be0 -> let (variable_sequence_number,be) = getVariableSequenceNumber freeVar.fv_info_ptr varHeap be0 in beNodeDef variable_sequence_number (convertExpr expr main_dcl_module_n varHeap) be collectStrictNodeIds :: Expression -> [FreeVar] collectStrictNodeIds (Let {let_strict_binds, let_expr}) - = [bind_dst \\ {bind_dst} <- let_strict_binds] +// MW0 = [bind_dst \\ {bind_dst} <- let_strict_binds] + = [lb_dst \\ {lb_dst} <- let_strict_binds] collectStrictNodeIds _ = [] diff --git a/backend/backendpreprocess.icl b/backend/backendpreprocess.icl index 31f81a2..8b0dd8c 100644 --- a/backend/backendpreprocess.icl +++ b/backend/backendpreprocess.icl @@ -113,11 +113,15 @@ instance sequence Selection where sequence (DictionarySelection dictionaryVar dictionarySelections _ index) = sequence index -instance sequence (Bind Expression FreeVar) where - sequence {bind_src=App app , bind_dst} - = sequence` app bind_dst +// MW0 instance sequence (Bind Expression FreeVar) where +instance sequence LetBind where +// MW0 sequence {bind_src=App app , bind_dst} + sequence {lb_src=App app , lb_dst} +// MW0 = sequence` app bind_dst + = sequence` app lb_dst where - sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId} +// MW0 sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId} + sequence` {app_symb, app_args} lb_dst sequenceState=:{ss_aliasDummyId} | app_symb.symb_name==ss_aliasDummyId // the compiled source was a strict alias like "#! x = y" = case hd app_args of @@ -126,13 +130,17 @@ instance sequence (Bind Expression FreeVar) where non_alias_bound_var = case vi of VI_SequenceNumber _ -> bound_var VI_Alias alias_bound_var-> alias_bound_var - ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap +// MW0 ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap + ss_varHeap = writePtr lb_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap -> { sequenceState & ss_varHeap = ss_varHeap } _ - -> sequence bind_dst sequenceState - = sequence bind_dst sequenceState +// MW0 -> sequence bind_dst sequenceState + -> sequence lb_dst sequenceState +// MW0 = sequence bind_dst sequenceState + = sequence lb_dst sequenceState sequence bind - = sequence bind.bind_dst +// MW0 = sequence bind.bind_dst + = sequence bind.lb_dst instance sequence FunctionPattern where sequence (FP_Algebraic _ subpatterns optionalVar) diff --git a/frontend/check.icl b/frontend/check.icl index ae7d3f6..514a350 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1289,7 +1289,7 @@ checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info (guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap (case_expr, es_expr_heap) = build_case guards defaul pattern_expr case_ident es_expr_heap - (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr es_expr_heap + (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr NoPos es_expr_heap = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) where @@ -1460,10 +1460,10 @@ where = (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident, case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, expr_heap) - bind_default_variable bind_src bind_dst result_expr expr_heap + bind_default_variable lb_src lb_dst result_expr expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - = (Let {let_strict_binds = [], let_lazy_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], - let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap) + = (Let {let_strict_binds = [], let_lazy_binds = [{ lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos }], + let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, expr_heap) bind_pattern_variables [] pattern_expr expr_heap = (pattern_expr, [], expr_heap) @@ -1471,7 +1471,7 @@ where # free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } (bound_var, expr_heap) = allocate_bound_var free_var expr_heap (pattern_expr, binds, expr_heap) = bind_pattern_variables variables (Var bound_var) expr_heap - = (pattern_expr, [{bind_src = this_pattern_expr, bind_dst = free_var} : binds], expr_heap) + = (pattern_expr, [{lb_src = this_pattern_expr, lb_dst = free_var, lb_position = NoPos } : binds], expr_heap) cons_optional (Yes var) variables = [ var : variables ] @@ -1715,12 +1715,13 @@ checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) -buildLetExpression :: !(Env Expression FreeVar) !(Env Expression FreeVar) !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) -buildLetExpression [] [] expr expr_heap +buildLetExpression :: ![LetBind] ![LetBind] !Expression !Position !*ExpressionHeap -> (!Expression, !*ExpressionHeap) +buildLetExpression [] [] expr _ expr_heap = (expr, expr_heap) -buildLetExpression let_strict_binds let_lazy_binds expr expr_heap +buildLetExpression let_strict_binds let_lazy_binds expr let_expr_position 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) + = (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, + let_info_ptr = let_expr_ptr, let_expr_position = let_expr_position }, 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 @@ -1741,53 +1742,58 @@ checkRhssAndTransformLocalDefs free_vars [] rhs_expr e_input e_state e_info cs = (rhs_expr, free_vars, e_state, e_info, cs) checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs # (binds, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars loc_defs e_input e_state e_info cs - (rhs_expr, es_expr_heap) = buildLetExpression [] binds rhs_expr e_state.es_expr_heap + (rhs_expr, es_expr_heap) = buildLetExpression [] binds rhs_expr NoPos e_state.es_expr_heap = (rhs_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) checkAndTransformPatternIntoBind free_vars [{nd_dst,nd_alts,nd_locals,nd_position} : local_defs] e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs # cs = pushErrorAdmin (newPosition {id_name="node definition", id_info=nilPtr} nd_position) cs # (bind_src, free_vars, e_state, e_info, cs) = checkRhs free_vars nd_alts nd_locals e_input e_state e_info cs (binds_of_bind, es_var_heap, es_expr_heap, e_info, cs) - = transfromPatternIntoBind ei_mod_index ei_expr_level nd_dst bind_src e_state.es_var_heap e_state.es_expr_heap e_info cs + = transfromPatternIntoBind ei_mod_index ei_expr_level nd_dst bind_src nd_position + e_state.es_var_heap e_state.es_expr_heap e_info cs e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap } (binds_of_local_defs, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars local_defs e_input e_state e_info cs = (binds_of_bind ++ binds_of_local_defs, free_vars, e_state, e_info, popErrorAdmin cs) checkAndTransformPatternIntoBind free_vars [] e_input e_state e_info cs = ([], free_vars, e_state, e_info, cs) -transfromPatternIntoBind :: !Index !Level !AuxiliaryPattern !Expression !*VarHeap !*ExpressionHeap !*ExpressionInfo !*CheckState - -> *(![Bind Expression FreeVar], !*VarHeap, !*ExpressionHeap, !*ExpressionInfo, !*CheckState) -transfromPatternIntoBind mod_index def_level (AP_Variable name var_info _) src_expr var_store expr_heap e_info cs - # bind = {bind_src = src_expr, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = def_level, fv_count = 0 }} +transfromPatternIntoBind :: !Index !Level !AuxiliaryPattern !Expression !Position !*VarHeap !*ExpressionHeap !*ExpressionInfo !*CheckState + -> *(![LetBind], !*VarHeap, !*ExpressionHeap, !*ExpressionInfo, !*CheckState) +transfromPatternIntoBind mod_index def_level (AP_Variable name var_info _) src_expr position var_store expr_heap e_info cs + # bind = {lb_src = src_expr, lb_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = def_level, fv_count = 0 }, lb_position = position } = ([bind], var_store, expr_heap, e_info, cs) transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_module,glob_object=ds_cons=:{ds_arity, ds_index, ds_ident}} type_index args opt_var) - src_expr var_store expr_heap e_info=:{ef_type_defs,ef_modules} cs - # (src_expr, opt_var_bind, var_store, expr_heap) = bind_opt_var opt_var src_expr var_store expr_heap + src_expr position var_store expr_heap e_info=:{ef_type_defs,ef_modules} cs + # (src_expr, opt_var_bind, var_store, expr_heap) = bind_opt_var opt_var src_expr position var_store expr_heap | ds_arity == 0 = ([], var_store, expr_heap, e_info, { cs & cs_error = checkError ds_ident " constant not allowed in a node pattern" cs.cs_error}) # (is_tuple, cs) = is_tuple_symbol glob_module ds_index cs | is_tuple - # (tuple_var, tuple_bind, var_store, expr_heap) = bind_match_expr src_expr opt_var_bind var_store expr_heap - = transform_sub_patterns mod_index def_level args ds_cons 0 tuple_var tuple_bind var_store expr_heap e_info cs + # (tuple_var, tuple_bind, var_store, expr_heap) = bind_match_expr src_expr opt_var_bind position var_store expr_heap + = transform_sub_patterns mod_index def_level args ds_cons 0 tuple_var tuple_bind position var_store expr_heap e_info cs # ({td_rhs}, ef_type_defs, ef_modules) = get_type_def mod_index glob_module type_index ef_type_defs ef_modules e_info = { e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules } = case td_rhs of RecordType {rt_fields} | size rt_fields == 1 - -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 src_expr opt_var_bind var_store expr_heap e_info cs + -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 + src_expr opt_var_bind position var_store expr_heap e_info cs # (record_var, record_bind, var_store, expr_heap) - = bind_match_expr src_expr opt_var_bind var_store expr_heap - -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 record_var record_bind var_store expr_heap e_info cs + = bind_match_expr src_expr opt_var_bind position var_store expr_heap + -> transform_sub_patterns_of_record mod_index def_level args rt_fields glob_module 0 + record_var record_bind position var_store expr_heap e_info cs _ | ds_arity == 1 # (binds, var_store, expr_heap, e_info, cs) - = transfromPatternIntoBind mod_index def_level (hd args) (MatchExpr No cons_symbol src_expr) var_store expr_heap e_info cs + = transfromPatternIntoBind mod_index def_level (hd args) (MatchExpr No cons_symbol src_expr) + position var_store expr_heap e_info cs -> (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs) # (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex ds_arity) PD_PredefinedModule STE_Type ds_arity cs (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex ds_arity) PD_PredefinedModule STE_Constructor ds_arity cs (match_var, match_bind, var_store, expr_heap) - = bind_match_expr (MatchExpr (Yes tuple_type) cons_symbol src_expr) opt_var_bind var_store expr_heap - -> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind var_store expr_heap e_info cs + = bind_match_expr (MatchExpr (Yes tuple_type) cons_symbol src_expr) opt_var_bind position var_store expr_heap + -> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind + position var_store expr_heap e_info cs where @@ -1803,44 +1809,48 @@ where = (tuple_2_symbol.glob_module == cons_module && tuple_2_symbol.glob_object.ds_index <= cons_index && cons_index <= tuple_2_symbol.glob_object.ds_index + 30, cs) - transform_sub_patterns mod_index def_level [pattern : patterns] tup_id tup_index arg_var all_binds var_store expr_heap e_info cs - # (this_arg_var, expr_heap) = adjust_match_expression arg_var expr_heap - match_expr = TupleSelect tup_id tup_index this_arg_var - (binds, var_store, expr_heap, e_info, cs) = transfromPatternIntoBind mod_index def_level pattern match_expr var_store expr_heap e_info cs - = transform_sub_patterns mod_index def_level patterns tup_id (inc tup_index) arg_var (binds ++ all_binds) var_store expr_heap e_info cs - transform_sub_patterns mod_index _ [] _ _ _ binds var_store expr_heap e_info cs + transform_sub_patterns mod_index def_level [pattern : patterns] tup_id tup_index arg_var all_binds position var_store expr_heap e_info cs + # (this_arg_var, expr_heap) + = adjust_match_expression arg_var expr_heap + match_expr + = TupleSelect tup_id tup_index this_arg_var + (binds, var_store, expr_heap, e_info, cs) + = transfromPatternIntoBind mod_index def_level pattern match_expr position var_store expr_heap e_info cs + = transform_sub_patterns mod_index def_level patterns tup_id (inc tup_index) arg_var (binds ++ all_binds) + position var_store expr_heap e_info cs + transform_sub_patterns mod_index _ [] _ _ _ binds _ var_store expr_heap e_info cs = (binds, var_store, expr_heap, e_info, cs) transform_sub_patterns_of_record mod_index def_level [pattern : patterns] fields field_module field_index record_expr - all_binds var_store expr_heap e_info cs + all_binds position var_store expr_heap e_info cs # {fs_name, fs_index} = fields.[field_index] selector = { glob_module = field_module, glob_object = MakeDefinedSymbol fs_name fs_index 1} (this_record_expr, expr_heap) = adjust_match_expression record_expr expr_heap (binds, var_store, expr_heap, e_info, cs) = transfromPatternIntoBind mod_index def_level pattern (Selection No this_record_expr [ RecordSelection selector field_index ]) - var_store expr_heap e_info cs + position var_store expr_heap e_info cs = transform_sub_patterns_of_record mod_index def_level patterns fields field_module (inc field_index) record_expr - (binds ++ all_binds) var_store expr_heap e_info cs - transform_sub_patterns_of_record mod_index _ [] _ _ _ _ binds var_store expr_heap e_info cs + (binds ++ all_binds) position var_store expr_heap e_info cs + transform_sub_patterns_of_record mod_index _ [] _ _ _ _ binds _ var_store expr_heap e_info cs = (binds, var_store, expr_heap, e_info, cs) - bind_opt_var (Yes {bind_src,bind_dst}) src_expr var_heap expr_heap + bind_opt_var (Yes {bind_src,bind_dst}) src_expr position var_heap expr_heap # free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } (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 } - = (Var bound_var, [{bind_src = src_expr, bind_dst = free_var}], var_heap <:= (bind_dst, VI_Empty), expr_heap) - bind_opt_var No src_expr var_heap expr_heap + = (Var bound_var, [{lb_src = src_expr, lb_dst = free_var, lb_position = position}], var_heap <:= (bind_dst, VI_Empty), expr_heap) + bind_opt_var No src_expr _ var_heap expr_heap = (src_expr, [], var_heap, expr_heap) - bind_match_expr var_expr=:(Var var) opt_var_bind var_heap expr_heap + bind_match_expr var_expr=:(Var var) opt_var_bind _ var_heap expr_heap = (var_expr, opt_var_bind, var_heap, expr_heap) - bind_match_expr match_expr opt_var_bind var_heap expr_heap + bind_match_expr match_expr opt_var_bind position var_heap expr_heap # new_name = newVarId "_x" (var_info_ptr, var_heap) = newPtr VI_Empty var_heap // (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap bound_var = { var_name = new_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } free_var = { fv_name = new_name, fv_info_ptr = var_info_ptr, fv_def_level = def_level, fv_count = 0 } - = (Var bound_var, [{bind_src = match_expr, bind_dst = free_var} : opt_var_bind], var_heap, expr_heap) + = (Var bound_var, [{lb_src = match_expr, lb_dst = free_var, lb_position = position } : opt_var_bind], var_heap, expr_heap) adjust_match_expression (Var var) expr_heap # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap @@ -1848,9 +1858,9 @@ where adjust_match_expression match_expr expr_heap = (match_expr, expr_heap) -transfromPatternIntoBind mod_index def_level (AP_WildCard _) src_expr var_store expr_heap e_info cs +transfromPatternIntoBind mod_index def_level (AP_WildCard _) src_expr _ var_store expr_heap e_info cs = ([], var_store, expr_heap, e_info, cs) -transfromPatternIntoBind _ _ pattern src_expr var_store expr_heap e_info cs +transfromPatternIntoBind _ _ pattern src_expr _ var_store expr_heap e_info cs = ([], var_store, expr_heap, e_info, { cs & cs_error = checkError "<pattern>" " illegal node pattern" cs.cs_error}) checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) fun_defs e_info heaps cs @@ -1880,7 +1890,7 @@ where (default_expr, free_vars, e_state, e_info, cs) = check_default_expr free_vars default_expr { e_input & ei_expr_level = last_expr_level } e_state e_info cs cs = { cs & cs_symbol_table = remove_seq_let_vars e_input.ei_expr_level let_vars_list cs.cs_symbol_table } - (result_expr, es_expr_heap) = convert_guards_to_cases rev_guarded_exprs default_expr e_state.es_expr_heap + (_, result_expr, es_expr_heap) = convert_guards_to_cases rev_guarded_exprs default_expr e_state.es_expr_heap = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) check_opt_guarded_alts free_vars (UnGuardedExpr unguarded_expr) e_input e_state e_info cs = check_unguarded_expression free_vars unguarded_expr e_input e_state e_info cs @@ -1897,14 +1907,14 @@ where case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], case_default = result_expr, case_ident = Yes guard_ident, case_info_ptr = case_expr_ptr, case_default_pos = NoPos } - = build_sequential_lets let_binds case_expr es_expr_heap + = build_sequential_lets let_binds case_expr NoPos es_expr_heap convert_guards_to_cases [(let_binds, guard, expr, guard_ident) : rev_guarded_exprs] result_expr es_expr_heap # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos } case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], case_default = result_expr, case_ident = Yes guard_ident, case_info_ptr = case_expr_ptr, case_default_pos = NoPos } - (result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr es_expr_heap + (_, result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr NoPos es_expr_heap = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expr_heap check_guarded_expressions free_vars [gexpr : gexprs] let_vars_list rev_guarded_exprs e_input e_state e_info cs @@ -1937,7 +1947,7 @@ where (expr, free_vars, e_state, e_info, cs) = addArraySelections array_patterns expr free_vars e_input e_state e_info cs cs = { cs & cs_symbol_table = remove_seq_let_vars rhs_expr_level let_vars_list cs.cs_symbol_table } - (seq_let_expr, es_expr_heap) = build_sequential_lets binds expr e_state.es_expr_heap + (_, seq_let_expr, es_expr_heap) = build_sequential_lets binds expr ewl_position e_state.es_expr_heap (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs seq_let_expr e_input { e_state & es_expr_heap = es_expr_heap} e_info cs (es_fun_defs, e_info, heaps, cs) @@ -1952,7 +1962,8 @@ where 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 :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState *ExpressionInfo *CheckState + -> *(![.([LetBind],![LetBind])],!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 @@ -1963,7 +1974,8 @@ where (binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars seq_lets [let_vars : let_vars_list] e_input e_state e_info cs (let_binds, es_var_heap, es_expr_heap, e_info, cs) - = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expr_heap e_info cs + = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr seq_let.ndwl_position + e_state.es_var_heap e_state.es_expr_heap e_info cs e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap } (strict_array_pattern_binds, lazy_array_pattern_binds, free_vars, e_state, e_info, cs) @@ -1993,13 +2005,13 @@ where e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs } = (src_expr, pattern, accus, free_vars, e_state, e_info, popErrorAdmin cs) - build_sequential_lets :: ![(![Bind Expression FreeVar],![Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap) - build_sequential_lets [] expr expr_heap - = (expr, expr_heap) - build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr expr_heap - # (let_expr, expr_heap) = build_sequential_lets seq_lets expr expr_heap - = buildLetExpression strict_binds lazy_binds let_expr expr_heap - + build_sequential_lets :: ![(![LetBind],![LetBind])] !Expression !Position !*ExpressionHeap -> (!Position, !Expression, !*ExpressionHeap) + build_sequential_lets [] expr let_expr_position expr_heap + = (let_expr_position, expr, expr_heap) + build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr let_expr_position expr_heap + # (let_expr_position, let_expr, expr_heap) = build_sequential_lets seq_lets expr let_expr_position expr_heap + (let_expr, expr_heap) = buildLetExpression strict_binds lazy_binds let_expr let_expr_position expr_heap + = (if (isEmpty strict_binds && isEmpty lazy_binds) let_expr_position NoPos, let_expr, expr_heap) newVarId name = { id_name = name, id_info = nilPtr } @@ -2024,8 +2036,9 @@ convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_e # (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 } free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } - (let_expr, expr_heap) = buildLetExpression [] [{ bind_src = Var bound_var, - bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] result_expr expr_heap + (let_expr, expr_heap) = buildLetExpression [] [{lb_src = Var bound_var, + lb_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }] result_expr NoPos expr_heap = (free_var, let_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) convertSubPattern (AP_Variable name var_info No) result_expr pattern_position var_store expr_heap opt_dynamics cs = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, pattern_position, @@ -2094,7 +2107,7 @@ addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs (let_expr_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap = ( Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, - let_expr = rhs_expr, let_info_ptr = let_expr_ptr } + let_expr = rhs_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos } , free_vars , { e_state & es_expr_heap = es_expr_heap} , e_info @@ -2112,7 +2125,7 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} # (bound_array_var, es_expr_heap) = allocate_bound_var ap_array_var e_state.es_expr_heap free_var = { fv_name = opt_var_ident, fv_info_ptr = opt_var_var_info_ptr, fv_def_level = NotALevel, fv_count = 0 } - -> ([{ bind_dst = free_var, bind_src = Var bound_array_var }: lazy_binds], + -> ([{ lb_dst = free_var, lb_src = Var bound_array_var, lb_position = NoPos }: lazy_binds], { e_state & es_expr_heap = es_expr_heap }) no -> (lazy_binds, e_state) = ([last_array_selection:strict_binds], lazy_binds, free_vars, e_state, e_info, cs) @@ -2146,9 +2159,9 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} selections = [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ] = ( new_array_var - , [ {bind_dst = var_for_uselect_result, bind_src = Selection opt_tuple_type (Var bound_array_var) selections} - , {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)} - , {bind_dst = array_element_var, bind_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result)} + , [ {lb_dst = var_for_uselect_result, lb_src = Selection opt_tuple_type (Var bound_array_var) selections, lb_position = NoPos } + , {lb_dst = new_array_var, lb_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result), lb_position = NoPos } + , {lb_dst = array_element_var, lb_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result), lb_position = NoPos } : binds ] , free_vars @@ -2261,19 +2274,22 @@ where # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (Let { let_strict_binds = [], let_lazy_binds= [ - { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, - bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, + { lb_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, + lb_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }], + let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, pattern_position, var_store, expr_heap, opt_dynamics, cs) # (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (Let { let_strict_binds = [], let_lazy_binds= [ - { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, - bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}, - { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, - bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, + { lb_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, + lb_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }, + { lb_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, + lb_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }], + let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, pattern_position, var_store, expr_heap, opt_dynamics, cs) No | var_info == fv_info_ptr @@ -2281,9 +2297,10 @@ where # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (Let { let_strict_binds = [], let_lazy_binds= - [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, - bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, + [{ lb_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, + lb_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }], + let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, pattern_position, var_store, expr_heap, opt_dynamics, cs) transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr pattern_position @@ -2331,9 +2348,10 @@ where (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, Let { let_strict_binds = [], let_lazy_binds = - [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, - bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, expr_heap) + [{ lb_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, + lb_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, + lb_position = NoPos }], + let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, expr_heap) transform_pattern_variable {fv_info_ptr,fv_name} No result_expr expr_heap # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap = (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap) @@ -3009,8 +3027,8 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func 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 main_dcl_module_n 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, 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, diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 1aa0d69..673b37e 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -742,8 +742,6 @@ instance e_corresponds DefinedSymbol where instance e_corresponds FunctionBody where // both bodies are either CheckedBodies or TransformedBodies e_corresponds dclDef iclDef -// | False--->("compare", from_body dclDef, from_body iclDef) -// = undef = e_corresponds (from_body dclDef) (from_body iclDef) where from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs]) @@ -824,6 +822,11 @@ instance e_corresponds Let where o` e_corresponds dclLet.let_lazy_binds iclLet.let_lazy_binds o` e_corresponds dclLet.let_expr iclLet.let_expr +instance e_corresponds LetBind where + e_corresponds dcl icl + = e_corresponds dcl.lb_src icl.lb_src + o` e_corresponds dcl.lb_dst icl.lb_dst + instance e_corresponds (Bind a b) | e_corresponds a & e_corresponds b where e_corresponds dcl icl = e_corresponds dcl.bind_src icl.bind_src @@ -941,6 +944,13 @@ e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Function dcl_glob_index} ec_state = continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index ec_state +e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalMacroFunction dcl_index} + icl_app_symb=:{symb_kind=SK_LocalMacroFunction icl_index} + ec_state + #! main_dcl_module_n=ec_state.ec_tc_state.tc_main_dcl_module_n + = continuation_for_possibly_twice_defined_funs dcl_app_symb + { glob_module = main_dcl_module_n, glob_object = dcl_index } icl_app_symb + { glob_module = main_dcl_module_n, glob_object = icl_index } ec_state e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_OverloadedFunction dcl_glob_index} icl_app_symb=:{symb_kind=SK_OverloadedFunction icl_glob_index} ec_state diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 3d33be5..cd2905c 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -101,6 +101,13 @@ where convertDynamics _ _ _ No ci = (No, ci) +instance convertDynamics LetBind +where + convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !LetBind !*ConversionInfo -> (!LetBind, !*ConversionInfo) + convertDynamics cinp bound_vars default_expr binding=:{lb_src} ci + # (lb_src, ci) = convertDynamics cinp bound_vars default_expr lb_src ci + = ({binding & lb_src = lb_src}, ci) + instance convertDynamics (Bind a b) | convertDynamics a where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo) | convertDynamics a @@ -135,7 +142,8 @@ where = (expr @ exprs, ci) convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci # (let_types, ci) = determine_let_types let_info_ptr ci - bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars +// MW0 bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars + bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars (let_strict_binds, ci) = convertDynamics cinp bound_vars default_expr let_strict_binds ci (let_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci (let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci @@ -205,7 +213,9 @@ where let_expr = App { app_symb = twoTuple_symb, app_args = [dyn_expr, dyn_type_code], app_info_ptr = nilPtr }, - let_info_ptr = let_info_ptr}, ci) +// MW0 let_info_ptr = let_info_ptr,}, ci) + let_info_ptr = let_info_ptr, + let_expr_position = NoPos}, ci) convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci = abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci convertDynamics cinp bound_vars default_expr EE ci @@ -358,13 +368,14 @@ where = [{ tv_free_var = {fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, tv_type = empty_attributed_type } : bound_vars] -open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, Bind Expression FreeVar, !*ConversionInfo) +open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo) open_dynamic dynamic_expr ci # (twotuple, ci) = getTupleSymbol 2 ci (dynamicType_var, ci) = newVariable "dt" VI_Empty ci dynamicType_fv = varToFreeVar dynamicType_var 1 = ( { opened_dynamic_expr = TupleSelect twotuple 0 dynamic_expr, opened_dynamic_type = Var dynamicType_var }, - { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv }, +// MW0 { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv }, + { lb_src = TupleSelect twotuple 1 dynamic_expr, lb_dst = dynamicType_fv, lb_position = NoPos }, { ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]}) /**************************************************************************************************/ @@ -395,7 +406,8 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = # - bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type +// MW0 bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type + bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars))) // c_1 ind_0 @@ -407,14 +419,17 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = # (tc_binds,ci) = foldSt remove_non_used_arg tc_binds ([],ci) - = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci) +// MW0 = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci) + = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, + let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci) where - remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo) - remove_non_used_arg tc_bind=:{bind_dst={fv_info_ptr}} (l,ci=:{ci_var_heap}) +// MW0 remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo) + remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo) + remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap}) # (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap | ref_count > 0 #! tc_bind - = { tc_bind & bind_dst = { tc_bind.bind_dst & fv_count = ref_count} } + = { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} } = ([tc_bind:l],{ci & ci_var_heap = ci_var_heap}) = (l,{ci & ci_var_heap = ci_var_heap}) @@ -440,15 +455,19 @@ where = addToBoundVars placeholder_var empty_attributed_type bound_vars = (bind,(bound_vars2,ci)); where - create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) +// MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) + create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo) create_variable var_name var_info_ptr ci # (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_fv = varToFreeVar cyclic_var 1 - = ({ bind_src = App { app_symb = placeholder_symb, - app_args = [Var cyclic_var, Var cyclic_var], - app_info_ptr = nilPtr }, - bind_dst = varToFreeVar cyclic_var 1 +// MW0 = ({ bind_src = App { app_symb = placeholder_symb, + = ({ lb_src = App { app_symb = placeholder_symb, + app_args = [Var cyclic_var, Var cyclic_var], + app_info_ptr = nilPtr }, +// MW0 bind_dst = varToFreeVar cyclic_var 1 + lb_dst = varToFreeVar cyclic_var 1, + lb_position = NoPos }, { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/) @@ -508,12 +527,17 @@ where # let_expr = Let { let_strict_binds = [] - , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [ - { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr }, - bind_dst = coerce_result_fv } +// MW0 , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [ +// MW0 { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr }, +// MW0 bind_dst = coerce_result_fv } + , let_lazy_binds = (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [ + { lb_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr }, + lb_dst = coerce_result_fv, lb_position = NoPos } , - { bind_src = TupleSelect twotuple 0 (Var coerce_result_var), - bind_dst = coerce_bool_fv } : let_binds +// MW0 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var), +// MW0 bind_dst = coerce_bool_fv } : let_binds + { lb_src = TupleSelect twotuple 0 (Var coerce_result_var), + lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds ], let_expr = Case { case_expr = Var coerce_bool_var, @@ -524,6 +548,7 @@ where case_info_ptr = case_info_ptr, case_default_pos= NoPos } // MW4++ , let_info_ptr = let_info_ptr + , let_expr_position = NoPos // MW0++ } // dp_rhs @@ -532,7 +557,8 @@ where opt (Yes x) = x convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo - -> (Env Expression FreeVar, Expression, *ConversionInfo) +/// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo) + -> ([LetBind], Expression, *ConversionInfo) convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default [{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci # /*** The last case may not have a default ***/ @@ -609,10 +635,14 @@ where a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds let_expr = Let { let_strict_binds = [], - let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, - bind_dst = unify_result_fv }, - { bind_src = TupleSelect twotuple 0 (Var unify_result_var), - bind_dst = unify_bool_fv } : let_binds +// MW0 let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, +// MW0 bind_dst = unify_result_fv }, +// MW0 { bind_src = TupleSelect twotuple 0 (Var unify_result_var), +// MW0 bind_dst = unify_bool_fv } : let_binds + let_lazy_binds = [{ lb_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, + lb_dst = unify_result_fv, lb_position = NoPos }, + { lb_src = TupleSelect twotuple 0 (Var unify_result_var), + lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds ], let_expr = Case { case_expr = Var unify_bool_var, // MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], @@ -621,13 +651,17 @@ where case_ident = No, case_info_ptr = case_info_ptr, case_default_pos= NoPos }, // MW4++ - let_info_ptr = let_info_ptr } +// MW0 let_info_ptr = let_info_ptr } + let_info_ptr = let_info_ptr, + let_expr_position = NoPos } = (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) where - add_x_i_bind bind_src bind_dst=:{fv_count} binds +// MW0 add_x_i_bind bind_src bind_dst=:{fv_count} binds + add_x_i_bind lb_src lb_dst=:{fv_count} binds | fv_count > 0 - = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ] +// MW0 = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ] + = [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ] = binds isLastDynamicPattern dp_rhs=:(Case keesje=:{case_guards=DynamicPatterns _}) @@ -643,7 +677,8 @@ where // other alternatives convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo - -> (Env Expression FreeVar, *ConversionInfo) +// MW0 -> (Env Expression FreeVar, *ConversionInfo) + -> ([LetBind], *ConversionInfo) convert_other_patterns _ _ _ _ _ _ No [] ci // no default and no alternatives left = ([], ci) @@ -669,7 +704,8 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h # (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap | ref_count > 0 # ind_fv = varToFreeVar var ref_count - = ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }], +// MW0 = ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }], + = ([{ lb_src = TupleSelect twotuple 1 (Var unify_result_var), lb_dst = ind_fv, lb_position = NoPos }], { ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]}) = ([], {ci & ci_var_heap = ci_var_heap}) @@ -679,12 +715,14 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h it is converted into a function. The references are replaced by an appropriate function application. */ -generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo) +// MW0 generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo) +generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(LetBind, *ConversionInfo) generateBinding cinp bound_vars var bind_expr result_type ci # (ref_count, ci) = get_reference_count var ci | ref_count == 0 # free_var = varToFreeVar var 1 - = ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]}) +// MW0 = ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]}) + = ({ lb_src = bind_expr, lb_dst = free_var, lb_position = NoPos }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]}) # (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap) (act_args, free_typed_vars, local_free_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap # @@ -696,10 +734,13 @@ generateBinding cinp bound_vars var bind_expr result_type ci = newFunction No (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}) local_free_vars arg_types result_type cinp.cinp_group_index (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) free_var = varToFreeVar var (inc ref_count) - = ({ bind_src = App { app_symb = fun_symb, - app_args = act_args, - app_info_ptr = nilPtr }, - bind_dst = free_var }, +// MW0 = ({ bind_src = App { app_symb = fun_symb, + = ({ lb_src = App { app_symb = fun_symb, + app_args = act_args, + app_info_ptr = nilPtr }, +// MW0 bind_dst = free_var }, + lb_dst = free_var, + lb_position = NoPos }, { ci & ci_var_heap = ci_var_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions, ci_fun_heap = ci_fun_heap, ci_new_variables = [ free_var : ci_new_variables ] }) where @@ -732,19 +773,24 @@ generateBinding cinp bound_vars var bind_expr result_type ci /**************************************************************************************************/ -createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo) +// MW0 createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo) +createVariables :: [VarInfoPtr] ![LetBind] !*ConversionInfo -> (![LetBind], !*ConversionInfo) createVariables var_info_ptrs binds ci = mapAppendSt (create_variable a_ij_var_name) var_info_ptrs binds ci -create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) +// MW0create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) +create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo) create_variable var_name var_info_ptr ci # (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_fv = varToFreeVar cyclic_var 1 - = ({ bind_src = App { app_symb = placeholder_symb, +// MW0 = ({ bind_src = App { app_symb = placeholder_symb, + = ({ lb_src = App { app_symb = placeholder_symb, app_args = [Var cyclic_var, Var cyclic_var], app_info_ptr = nilPtr }, - bind_dst = varToFreeVar cyclic_var 1 +// MW0 bind_dst = varToFreeVar cyclic_var 1 + lb_dst = varToFreeVar cyclic_var 1, + lb_position = NoPos }, { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]}) diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 9b6df9d..88a142c 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -28,6 +28,12 @@ where convertCases bound_vars group_index common_defs t ci = app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t ci +instance convertCases LetBind +where + convertCases bound_vars group_index common_defs bind=:{lb_src} ci + # (lb_src, ci) = convertCases bound_vars group_index common_defs lb_src ci + = ({ bind & lb_src = lb_src }, ci) + instance convertCases (Bind a b) | convertCases a where convertCases bound_vars group_index common_defs bind=:{bind_src} ci @@ -55,8 +61,10 @@ where _ -> abort "convertCases [Let] (convertcases 53)" // <<- let_info -addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars - = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ] +// MW0 addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars +// MW0 = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ] +addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars + = addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ] addLetVars [] _ bound_vars = bound_vars @@ -805,8 +813,10 @@ where # (let_expr, cp_info) = copy let_expr cp_info = (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cp_info) where - bind_let_var {bind_dst} (local_vars, var_heap) - = ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar)) +// MW0 bind_let_var {bind_dst} (local_vars, var_heap) +// MW0 = ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar)) + bind_let_var {lb_dst} (local_vars, var_heap) + = ([lb_dst : local_vars], var_heap <:= (lb_dst.fv_info_ptr, VI_LocalVar)) copy (Case case_expr) cp_info # (case_expr, cp_info) = copy case_expr cp_info = (Case case_expr, cp_info) @@ -947,6 +957,12 @@ instance copy (a,b) | copy a & copy b where copy t cp_info = app2St (copy, copy) t cp_info +instance copy LetBind +where + copy bind=:{lb_src} cp_info + # (lb_src, cp_info) = copy lb_src cp_info + = ({ bind & lb_src = lb_src }, cp_info) + instance copy (Bind a b) | copy a where copy bind=:{bind_src} cp_info @@ -1027,7 +1043,8 @@ where where remove_variable ([], var_heap) let_bind = ([], var_heap) - remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}} +// MW0 remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}} + remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_name,fv_info_ptr}} | fv_info_ptr == var_ptr # (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap = (var_ptrs, var_heap) @@ -1035,11 +1052,14 @@ where # (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind = ([var_ptr : var_ptrs], var_heap) - store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap +// MW0 store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap + store_binding {lb_dst={fv_name,fv_info_ptr},lb_src} var_heap = var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [], - lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name}) +// MW0 lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name}) + lvi_new = True, lvi_expression = lb_src, lvi_var = fv_name}) - get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap +// MW0 get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap + get_ref_count {lb_dst={fv_name,fv_info_ptr}} var_heap # (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap = (lvi_count, var_heap) // ==> (fv_name,fv_info_ptr,lvi_count) @@ -1227,6 +1247,11 @@ instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b where weightedRefCount dcl_functions common_defs depth (x,y) rc_info = weightedRefCount dcl_functions common_defs depth y (weightedRefCount dcl_functions common_defs depth x rc_info) +instance weightedRefCount LetBind +where + weightedRefCount dcl_functions common_defs depth {lb_src} rc_info + = weightedRefCount dcl_functions common_defs depth lb_src rc_info + instance weightedRefCount (Bind a b) | weightedRefCount a where weightedRefCount dcl_functions common_defs depth bind=:{bind_src} rc_info @@ -1324,15 +1349,23 @@ where _ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []}, {dl_info & di_expr_heap = dl_info.di_expr_heap <:= (let_info_ptr, EI_LetType (take nr_of_strict_lets let_type))}) where +/* MW0 set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap lei = { lei_count = ref_count, lei_depth = depth, lei_var = { bind_dst & fv_info_ptr = new_info_ptr }, lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched } = set_let_expression_info depth binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei)) +*/ + set_let_expression_info depth [(let_strict, {lb_src,lb_dst}):binds][ref_count:ref_counts][type:types] var_heap + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + lei = { lei_count = ref_count, lei_depth = depth, lei_var = { lb_dst & fv_info_ptr = new_info_ptr }, + lei_expression = lb_src, lei_type = type, lei_status = LES_Untouched } + = set_let_expression_info depth binds ref_counts types (var_heap <:= (lb_dst.fv_info_ptr, VI_LetExpression lei)) set_let_expression_info depth [] _ _ var_heap = var_heap - distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap} +// MW0 distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap} + distribute_lets_in_non_distributed_let depth {lb_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap} # (VI_LetExpression lei=:{lei_depth,lei_count,lei_status}, di_var_heap) = readPtr fv_info_ptr di_var_heap | lei_count > 0 // | not lei_moved && lei_count > 0 @@ -1475,10 +1508,14 @@ buildLetExpr let_vars let_expr (var_heap, expr_heap) -> (Let { inner_let & let_lazy_binds = lazy_binds }, (var_heap, expr_heap)) _ # (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap - -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) +// MW0 -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap)) + -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, + let_info_ptr = let_info_ptr, let_expr_position = NoPos }, (var_heap, expr_heap)) where - build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap) - -> (!Env Expression FreeVar, ![AType], !*VarHeap) +// MW0 build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap) +// MW0 -> (!Env Expression FreeVar, ![AType], !*VarHeap) + build_bind :: !VarInfoPtr !(![LetBind], ![AType], !*VarHeap) + -> (![LetBind], ![AType], !*VarHeap) build_bind info_ptr (lazy_binds, lazy_binds_types, var_heap) # (let_info, var_heap) = readPtr info_ptr var_heap # (VI_LetExpression lei=:{lei_var,lei_expression,lei_status,lei_type}) = let_info @@ -1486,7 +1523,8 @@ where (new_info_ptr, var_heap) = newPtr VI_Empty var_heap var_heap = var_heap <:= (info_ptr, VI_LetExpression { lei & lei_status = LES_Untouched, lei_var = { lei_var & fv_info_ptr = new_info_ptr }}) // ==> (lei_var.fv_name, info_ptr, new_info_ptr) - = ([{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) +// MW0 = ([{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) + = ([{ lb_src = updated_expr, lb_dst = lei_var, lb_position = NoPos } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) instance distributeLets Selection where @@ -1504,6 +1542,12 @@ instance distributeLets [a] | distributeLets a where distributeLets depth l cp_info = mapSt (distributeLets depth) l cp_info +instance distributeLets LetBind +where + distributeLets depth bind=:{lb_src} cp_info + # (lb_src, cp_info) = distributeLets depth lb_src cp_info + = ({ bind & lb_src = lb_src }, cp_info) + instance distributeLets (Bind a b) | distributeLets a where distributeLets depth bind=:{bind_src} cp_info diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index bcc6b0e..822de3e 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -667,9 +667,9 @@ instance check_completeness BasicPattern where check_completeness {bp_expr} cci ccs = check_completeness bp_expr cci ccs -instance check_completeness (Bind Expression FreeVar) where - check_completeness {bind_src} cci ccs - = check_completeness bind_src cci ccs +instance check_completeness LetBind where + check_completeness {lb_src} cci ccs + = check_completeness lb_src cci ccs instance check_completeness Case where check_completeness { case_expr, case_guards, case_default } cci ccs diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 392c525..57b6d1f 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -111,7 +111,12 @@ unboxError type err overloadingError op_symb err # err = errorHeading "Overloading error" err - = { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< op_symb <<< "\" could not be solved\n" } + str = case optBeautifulizeIdent op_symb.id_name of + No + -> op_symb.id_name + Yes (str, line_nr) + -> str+++" [line "+++toString line_nr+++"]" + = { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< str <<< "\" could not be solved\n" } /* As soon as all overloaded variables in an type context are instantiated, context reduction is carried out. @@ -736,7 +741,8 @@ where | isEmpty let_binds = (dict_expr, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, class_ptrs)) # (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap - = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr }, +// MW0 = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr }, + = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, [let_info_ptr : class_ptrs])) # dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module expressions context_size dictionary_args (dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs heaps.hp_expression_heap class_ptrs @@ -771,13 +777,16 @@ where (var_info_ptr, var_heap) = newPtr VI_Empty var_heap fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } - = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) +// MW0 = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) + = ([{lb_src = dict, lb_dst = fv, lb_position = NoPos } : binds ], [ AttributedType class_type : types ], + [Var var : rev_dicts], var_heap, expr_heap) bind_shared_dictionary nr_of_members dict=:(App {app_symb={symb_name}, app_info_ptr}) (binds, types, rev_dicts, var_heap, expr_heap) # (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap (var_info_ptr, var_heap) = newPtr VI_Empty var_heap fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } - = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) +// MW0 = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) + = ([{lb_src = dict, lb_dst = fv, lb_position = NoPos} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) bind_shared_dictionary nr_of_members dict (binds, types, rev_dicts, var_heap, expr_heap) = (binds, types, [dict : rev_dicts], var_heap, expr_heap) @@ -1209,8 +1218,10 @@ where examine_calls_in_expr _ ui = ui - examine_calls_bind {bind_src,bind_dst} ui=:{ui_local_vars} - = examine_calls_in_expr bind_src { ui & ui_local_vars = [bind_dst : ui_local_vars ]} +// MW0 examine_calls_bind {bind_src,bind_dst} ui=:{ui_local_vars} +// MW0 = examine_calls_in_expr bind_src { ui & ui_local_vars = [bind_dst : ui_local_vars ]} + examine_calls_bind {lb_src,lb_dst} ui=:{ui_local_vars} + = examine_calls_in_expr lb_src { ui & ui_local_vars = [lb_dst : ui_local_vars ]} examine_calls [] ui = ui @@ -1252,6 +1263,12 @@ where updateExpression group_index expr ui = (expr, ui) +instance updateExpression LetBind +where + updateExpression group_index bind=:{lb_src} ui + # (lb_src, ui) = updateExpression group_index lb_src ui + = ({bind & lb_src = lb_src }, ui) + instance updateExpression (Bind a b) | updateExpression a where updateExpression group_index bind=:{bind_src} ui @@ -1352,7 +1369,8 @@ where = ( Let { let_strict_binds = [] , let_lazy_binds = let_binds , let_expr = expr - , let_info_ptr = let_info_ptr} + , let_info_ptr = let_info_ptr + , let_expr_position = NoPos} // MW0++ , ui) = (expr, ui) where @@ -1397,10 +1415,13 @@ where # (placeholder_symb, ui) = getSymbol PD_variablePlaceholder SK_Constructor 3 ui cyclic_var = {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_fv = varToFreeVar cyclic_var 1 - = ({ bind_src = App { app_symb = placeholder_symb, +// MW0 = ({ bind_src = App { app_symb = placeholder_symb, + = ({ lb_src = App { app_symb = placeholder_symb, app_args = [Var cyclic_var, Var cyclic_var], app_info_ptr = nilPtr }, - bind_dst = varToFreeVar cyclic_var 1 +// MW0 bind_dst = varToFreeVar cyclic_var 1 + lb_dst = varToFreeVar cyclic_var 1, + lb_position = NoPos }, { ui & ui_local_vars = [cyclic_fv : ui.ui_local_vars]}) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index d60192a..b571046 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -100,7 +100,8 @@ where = refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap) refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap | isEmpty let_lazy_binds - # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars] +// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars] + # new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars] # (observing, var_heap) = binds_are_observing let_strict_binds var_heap | observing # var_heap = saveOccurrences free_vars var_heap @@ -109,7 +110,8 @@ where var_heap = refMark new_free_vars sel let_expr var_heap = let_combine free_vars var_heap = refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap) - # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars] +// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars] + # new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars] var_heap = foldSt bind_variable let_strict_binds var_heap var_heap = foldSt bind_variable let_lazy_binds var_heap = refMark new_free_vars sel let_expr var_heap @@ -118,7 +120,8 @@ where binds_are_observing binds var_heap = foldr bind_is_observing (True, var_heap) binds where - bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) +// MW0 bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) + bind_is_observing {lb_dst={fv_info_ptr}} (observe, var_heap) # (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap = (occ_observing && observe, var_heap) @@ -131,10 +134,12 @@ where comb_ref_count = parCombineRefCount (seqCombineRefCount occ_ref_count prev_ref_count) pre_pref_recount = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses }) - bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap +// MW0 bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap + bind_variable {lb_src,lb_dst={fv_info_ptr}} var_heap # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap // = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src }) - = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src }) +// MW0 = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src }) + = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src }) refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap = refMarkOfCase free_vars sel case_expr case_guards case_default var_heap @@ -182,10 +187,17 @@ where isUsed RC_Unused = False isUsed _ = True +instance refMark LetBind +where + refMark free_vars sel {lb_src} var_heap + = refMark free_vars NotASelector lb_src var_heap + +/* MW0 not necessary anymore instance refMark (Bind a b) | refMark a where refMark free_vars sel {bind_src} var_heap = refMark free_vars NotASelector bind_src var_heap +*/ instance refMark Selection where diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index efb68d2..57465ba 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1034,10 +1034,17 @@ cIsNotStrict :== False } :: Let = - { let_strict_binds :: !Env Expression FreeVar - , let_lazy_binds :: !Env Expression FreeVar + { let_strict_binds :: ![LetBind] + , let_lazy_binds :: ![LetBind] , let_expr :: !Expression , let_info_ptr :: !ExprInfoPtr + , let_expr_position :: !Position + } + +:: LetBind = + { lb_dst :: !FreeVar + , lb_src :: !Expression + , lb_position :: !Position } :: Conditional = @@ -1160,7 +1167,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo, BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns, (Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification, - TypeCodeExpression, CoercionPosition, AttrInequality + TypeCodeExpression, CoercionPosition, AttrInequality, LetBind instance == TypeAttribute instance == Annotation diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 086c7b3..ba2056d 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -995,10 +995,17 @@ cIsNotStrict :== False } :: Let = - { let_strict_binds :: !Env Expression FreeVar - , let_lazy_binds :: !Env Expression FreeVar + { let_strict_binds :: ![LetBind] + , let_lazy_binds :: ![LetBind] , let_expr :: !Expression , let_info_ptr :: !ExprInfoPtr + , let_expr_position :: !Position + } + +:: LetBind = + { lb_dst :: !FreeVar + , lb_src :: !Expression + , lb_position :: !Position } :: DynamicExpr = @@ -1083,7 +1090,6 @@ cIsNotStrict :== False , ip_file :: !FileName } - :: FileName :== String :: FunctName :== String @@ -1417,6 +1423,11 @@ where (<<<) file expr = abort ("<<< (Expression) [line 1290]" )//<<- expr) +instance <<< LetBind +where + (<<<) file {lb_dst, lb_src} + = file <<< lb_dst <<< " = " <<< lb_src <<< "\n" + instance <<< TypeCase where (<<<) file {type_case_dynamic,type_case_patterns,type_case_default} diff --git a/frontend/transform.icl b/frontend/transform.icl index 6751298..d7fc6f6 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -159,6 +159,12 @@ where # (app_args, ls) = lift app_args ls = ({ app & app_args = app_args }, ls) +instance lift LetBind +where + lift bind=:{lb_src} ls + # (lb_src, ls) = lift lb_src ls + = ({ bind & lb_src = lb_src }, ls) + instance lift (Bind a b) | lift a where lift bind=:{bind_src} ls @@ -379,6 +385,12 @@ where substitute_EI_DictionaryType x opt_type_heaps = (x, opt_type_heaps) +instance unfold LetBind +where + unfold bind=:{lb_src} us + # (lb_src, us) = unfold lb_src us + = ({ bind & lb_src = lb_src }, us) + instance unfold (Bind a b) | unfold a where unfold bind=:{bind_src} us @@ -470,10 +482,10 @@ where = ({lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr, let_info_ptr = new_info_ptr}, { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps }) where - copy_bound_vars [bind=:{bind_dst} : binds] us - # (bind_dst, us) = unfold bind_dst us + copy_bound_vars [bind=:{lb_dst} : binds] us + # (lb_dst, us) = unfold lb_dst us (binds, us) = copy_bound_vars binds us - = ([ {bind & bind_dst = bind_dst} : binds ], us) + = ([ {bind & lb_dst = lb_dst} : binds ], us) copy_bound_vars [] us = ([], us) @@ -554,8 +566,9 @@ unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} | isEmpty let_binds = (result_expr, fun_defs, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table })) # (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap - = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr}, fun_defs, - (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table })) + = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, + let_info_ptr = new_info_ptr, let_expr_position = NoPos }, fun_defs, + (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table })) where bind_expressions [var : vars] [expr : exprs] binds var_heap @@ -574,7 +587,7 @@ where = (binds, writePtr fv_info_ptr (VI_Expression expr) var_heap) # (new_info, var_heap) = newPtr VI_Empty var_heap new_var = { fv_name = fv_name, fv_def_level = NotALevel, fv_info_ptr = new_info, fv_count = 0 } - = ([{ bind_src = expr, bind_dst = new_var} : binds], writePtr fv_info_ptr (VI_Variable fv_name new_info) var_heap) + = ([{ lb_src = expr, lb_dst = new_var, lb_position = NoPos} : binds], writePtr fv_info_ptr (VI_Variable fv_name new_info) var_heap) :: Group = @@ -907,7 +920,7 @@ where _ -> var_info_ptr - set_alias {bind_src=Var var,bind_dst={fv_info_ptr}} var_heap + set_alias {lb_src=Var var,lb_dst={fv_info_ptr}} var_heap = var_heap <:= (fv_info_ptr, VI_Alias var) set_alias _ var_heap = var_heap @@ -936,13 +949,13 @@ where (let_lazy_binds, var_heap, expr_heap) = foldSt replace_variables_in_bound_expression rev_let_lazy_binds ([], var_heap, expr_heap) = (Let { lad & let_lazy_binds = let_lazy_binds, let_info_ptr = let_info_ptr, let_expr = expr}, var_heap, expr_heap) where - renew_let_var bind=:{bind_dst} (rev_binds, var_heap) - # (bind_dst, var_heap) = new_variable bind_dst var_heap - = ([{ bind & bind_dst = bind_dst } : rev_binds], var_heap) + renew_let_var bind=:{lb_dst} (rev_binds, var_heap) + # (lb_dst, var_heap) = new_variable lb_dst var_heap + = ([{ bind & lb_dst = lb_dst } : rev_binds], var_heap) - replace_variables_in_bound_expression bind=:{bind_src} (rev_binds, var_heap, expr_heap) - # (bind_src, var_heap, expr_heap) = replace_variables_in_expression bind_src var_heap expr_heap - = ([{ bind & bind_src = bind_src } : rev_binds], var_heap, expr_heap) + replace_variables_in_bound_expression bind=:{lb_src} (rev_binds, var_heap, expr_heap) + # (lb_src, var_heap, expr_heap) = replace_variables_in_expression lb_src var_heap expr_heap + = ([{ bind & lb_src = lb_src } : rev_binds], var_heap, expr_heap) push_let_expression_into_guards lad (AlgebraicPatterns type patterns) var_heap expr_heap @@ -1240,6 +1253,12 @@ where = (record_selection, fun_and_macro_defs, modules, es) +instance expand LetBind +where + expand bind=:{lb_src} fun_and_macro_defs mod_index modules es + # (lb_src, fun_and_macro_defs, modules, es) = expand lb_src fun_and_macro_defs mod_index modules es + = ({ bind & lb_src = lb_src }, fun_and_macro_defs, modules, es) + instance expand (Bind a b) | expand a where expand bind=:{bind_src} fun_and_macro_defs mod_index modules es @@ -1318,10 +1337,10 @@ where clearCount [] locality var_heap = var_heap -instance clearCount (Bind a b) | clearCount b +instance clearCount LetBind where - clearCount bind=:{bind_dst} locality var_heap - = clearCount bind_dst locality var_heap + clearCount bind=:{lb_dst} locality var_heap + = clearCount lb_dst locality var_heap instance clearCount FreeVar where @@ -1376,7 +1395,7 @@ where the reference count info. */ - determine_aliases [{bind_dst={fv_info_ptr}, bind_src = Var var} : binds] var_heap + determine_aliases [{lb_dst={fv_info_ptr}, lb_src = Var var} : binds] var_heap = determine_aliases binds (writePtr fv_info_ptr (VI_Alias var) var_heap) determine_aliases [bind : binds] var_heap = determine_aliases binds (clearCount bind cIsALocalVar var_heap) @@ -1389,7 +1408,8 @@ where detect_cycles_and_handle_alias_binds is_strict [] cos = (cContainsNoCycle, [], cos) - detect_cycles_and_handle_alias_binds is_strict [bind=:{bind_dst={fv_info_ptr}} : binds] cos +// detect_cycles_and_handle_alias_binds is_strict [bind=:{bind_dst={fv_info_ptr}} : binds] cos + detect_cycles_and_handle_alias_binds is_strict [bind=:{lb_dst={fv_info_ptr}} : binds] cos #! var_info = sreadPtr fv_info_ptr cos.cos_var_heap = case var_info of VI_Alias {var_info_ptr} @@ -1397,11 +1417,11 @@ where -> (cContainsACycle, binds, cos) | is_strict # cos_var_heap = writePtr fv_info_ptr (VI_Count 0 cIsALocalVar) cos.cos_var_heap - (new_bind_src, cos) = add_dummy_id_for_strict_alias bind.bind_src + (new_bind_src, cos) = add_dummy_id_for_strict_alias bind.lb_src { cos & cos_var_heap = cos_var_heap } (is_cyclic, binds, cos) = detect_cycles_and_handle_alias_binds is_strict binds cos - -> (is_cyclic, [{ bind & bind_src = new_bind_src } : binds], cos) + -> (is_cyclic, [{ bind & lb_src = new_bind_src } : binds], cos) -> detect_cycles_and_handle_alias_binds is_strict binds cos _ # (is_cyclic, binds, cos) = detect_cycles_and_handle_alias_binds is_strict binds cos @@ -1437,13 +1457,13 @@ where = collect_variables_in_binds binds collected_binds free_vars cos = (collected_binds, free_vars, cos) - examine_reachable_binds bind_found [bind=:(is_strict, {bind_dst=fv=:{fv_info_ptr},bind_src}) : binds] collected_binds free_vars cos + examine_reachable_binds bind_found [bind=:(is_strict, {lb_dst=fv=:{fv_info_ptr},lb_src}) : binds] collected_binds free_vars cos # (bind_found, binds, collected_binds, free_vars, cos) = examine_reachable_binds bind_found binds collected_binds free_vars cos #! var_info = sreadPtr fv_info_ptr cos.cos_var_heap # (VI_Count count is_global) = var_info | count > 0 - # (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos - = (True, binds, [ (is_strict, { bind_dst = { fv & fv_count = count }, bind_src = bind_src }) : collected_binds ], free_vars, cos) + # (lb_src, free_vars, cos) = collectVariables lb_src free_vars cos + = (True, binds, [ (is_strict, { snd bind & lb_dst = { fv & fv_count = count }, lb_src = lb_src }) : collected_binds ], free_vars, cos) = (bind_found, [bind : binds], collected_binds, free_vars, cos) examine_reachable_binds bind_found [] collected_binds free_vars cos = (bind_found, [], collected_binds, free_vars, cos) @@ -1575,7 +1595,7 @@ where -> (var, [{fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars ], { cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap }) _ - -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name) + -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) instance <<< (Ptr a) where diff --git a/frontend/type.icl b/frontend/type.icl index e500538..d925719 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -44,7 +44,6 @@ import RWSDebug } // MW4 added.. -// one TypeCoercionGroup collects coercions for one function alternative :: TypeCoercionGroup = { tcg_type_coercions :: ![TypeCoercion] , tcg_position :: !Position @@ -414,9 +413,10 @@ cannotUnify t1 t2 position err */ cannotUnify t1 t2 position=:(CP_Expression expr) err=:{ea_loc=[ip:_]} - = case tryToOptimizePosition expr ip of - Yes ident_pos - # err = pushErrorAdmin ident_pos err + = case tryToOptimizePosition expr of +// MW0 Yes ident_pos + Yes (id_name, line) + # err = pushErrorAdmin { ip & ip_ident.id_name = id_name, ip_line = line } err err = errorHeading type_error err err = popErrorAdmin err -> { err & ea_file = err.ea_file <<< " cannot unify " <:: (type_error_format, t1, Yes initialTypeVarBeautifulizer) @@ -443,47 +443,15 @@ cannot_unify t1 t2 position err = { err & ea_file = ea_file <<< '\n' } // MW4.. -tryToOptimizePosition (Case {case_ident=Yes {id_name}}) ip - = tryToOptimizePositionFromString id_name ip -tryToOptimizePosition (App {app_symb={symb_name}}) ip - = tryToOptimizePositionFromString symb_name.id_name ip -tryToOptimizePosition (fun @ _) ip - = tryToOptimizePosition fun ip -tryToOptimizePosition _ _ +tryToOptimizePosition (Case {case_ident=Yes {id_name}}) + = optBeautifulizeIdent id_name +tryToOptimizePosition (App {app_symb={symb_name}}) + = optBeautifulizeIdent symb_name.id_name +tryToOptimizePosition (fun @ _) + = tryToOptimizePosition fun +tryToOptimizePosition _ = No -tryToOptimizePositionFromString id_name ip - # fst_semicolon_index = searchlArrElt ((==) ';') id_name 0 - | fst_semicolon_index < size id_name - # snd_semicolon_index = searchlArrElt ((==) ';') id_name (fst_semicolon_index+1) - prefix = id_name % (0, fst_semicolon_index-1) - line = toInt (id_name % (fst_semicolon_index+1, snd_semicolon_index-1)) - = Yes { ip & ip_ident = { id_name = prefix_to_readable_name prefix, id_info = nilPtr }, ip_line = line } - = No - where - prefix_to_readable_name "_c" = "case" - prefix_to_readable_name "_g" = "guard" - prefix_to_readable_name "_f" = "filter" - prefix_to_readable_name "\\" = "lambda" - prefix_to_readable_name prefix - | prefix.[0] == 'c' - = "comprehension" - | prefix.[0] == 'g' - = "generator" - prefix_to_readable_name _ = abort "fatal error 21 in type.icl" - -// search for an element in an array -searchlArrElt p s i - :== searchl s i - where - searchl s i - | i>=size s - = i - | p s.[i] - = i - = searchl s (i+1) -// ..MW4 - class unify a :: !a !a !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps) instance unify (a, b) | unify, arraySubst a & unify, arraySubst b @@ -1344,31 +1312,83 @@ where instance requirements Let where +/* MW0 was requirements ti {let_lazy_binds, let_strict_binds, let_expr, let_info_ptr} (reqs, ts) # let_binds = let_strict_binds ++ let_lazy_binds (rev_var_types, ts) = make_base let_binds [] ts var_types = reverse rev_var_types (res_type, opt_expr_ptr, reqs_ts) = requirements ti let_expr (reqs, ts) - (reqs, ts) = requirements_of_binds ti let_binds var_types reqs_ts + (reqs, ts) = requirements_of_binds ti let_binds var_types reqs_ts + ts_expr_heap = writePtr let_info_ptr (EI_LetType var_types) ts.ts_expr_heap + = ( res_type, opt_expr_ptr, ({ reqs & req_case_and_let_exprs = [let_info_ptr : reqs.req_case_and_let_exprs]},{ ts & ts_expr_heap = ts_expr_heap })) +*/ + requirements ti {let_lazy_binds, let_strict_binds, let_expr, let_info_ptr, let_expr_position } (reqs, ts) + # let_binds = let_strict_binds ++ let_lazy_binds + (rev_var_types, ts) = make_base let_binds [] ts + var_types = reverse rev_var_types + (reqs, ts) = requirements_of_binds NoPos ti let_binds var_types (reqs, ts) + (res_type, opt_expr_ptr, (reqs, ts)) = requirements_of_let_expr let_expr_position ti let_expr (reqs, ts) ts_expr_heap = writePtr let_info_ptr (EI_LetType var_types) ts.ts_expr_heap = ( res_type, opt_expr_ptr, ({ reqs & req_case_and_let_exprs = [let_info_ptr : reqs.req_case_and_let_exprs]},{ ts & ts_expr_heap = ts_expr_heap })) where - make_base [{bind_src, bind_dst={fv_name, fv_info_ptr}}:bs] var_types ts=:{ts_var_heap} +// MW0 make_base [{bind_src, bind_dst={fv_name, fv_info_ptr}}:bs] var_types ts=:{ts_var_heap} + make_base [{lb_src, lb_dst={fv_name, fv_info_ptr}}:bs] var_types ts=:{ts_var_heap} # (v, ts) = freshAttributedVariable ts - optional_position = if (is_rare_name fv_name) (Yes (CP_Expression bind_src)) No +// MW0 optional_position = if (is_rare_name fv_name) (Yes (CP_Expression bind_src)) No + optional_position = if (is_rare_name fv_name) (Yes (CP_Expression lb_src)) No = make_base bs [v:var_types] { ts & ts_var_heap = writePtr fv_info_ptr (VI_Type v optional_position) ts.ts_var_heap } make_base [] var_types ts = (var_types, ts) - requirements_of_binds _ [] _ reqs_ts +// MW0 requirements_of_binds _ [] _ reqs_ts + requirements_of_binds _ _ [] _ reqs_ts = reqs_ts +/* MW0 requirements_of_binds ti [{bind_src}:bs] [b_type:bts] reqs_ts # (exp_type, opt_expr_ptr, (reqs, ts)) = requirements ti bind_src reqs_ts ts_expr_heap = storeAttribute opt_expr_ptr b_type.at_attribute ts.ts_expr_heap req_type_coercions = [ { tc_demanded = b_type, tc_offered = exp_type, tc_position = CP_Expression bind_src, tc_coercible = True } : reqs.req_type_coercions ] = requirements_of_binds ti bs bts ({ reqs & req_type_coercions = req_type_coercions }, { ts & ts_expr_heap = ts_expr_heap }) +*/ + requirements_of_binds last_position ti [{lb_src, lb_position}:bs] [b_type:bts] reqs_ts + # position = if (is_a_new_position lb_position last_position) lb_position NoPos + reqs_ts + = possibly_accumulate_reqs_in_new_group position (requirements_of_bind b_type ti lb_src) reqs_ts + = requirements_of_binds lb_position ti bs bts reqs_ts + where + is_a_new_position (LinePos _ line_nr1) (LinePos _ line_nr2) + = line_nr1<>line_nr2 + is_a_new_position (FunPos _ line_nr1 _) (FunPos _ line_nr2 _) + = line_nr1<>line_nr2 + is_a_new_position _ _ + = True + + requirements_of_bind b_type ti lb_src reqs_ts + # (exp_type, opt_expr_ptr, (reqs, ts)) + = requirements ti lb_src reqs_ts + ts_expr_heap = storeAttribute opt_expr_ptr b_type.at_attribute ts.ts_expr_heap + req_type_coercions = [ { tc_demanded = b_type, tc_offered = exp_type, tc_position = CP_Expression lb_src, tc_coercible = True } + : reqs.req_type_coercions ] + = ({ reqs & req_type_coercions = req_type_coercions }, { ts & ts_expr_heap = ts_expr_heap }) + + requirements_of_let_expr NoPos ti let_expr reqs_ts + = requirements ti let_expr reqs_ts + requirements_of_let_expr let_expr_position ti let_expr (reqs=:{req_type_coercions=old_req_type_coercions}, ts) + # reqs_with_empty_accu + = { reqs & req_type_coercions = [] } + (res_type, opt_expr_ptr, (reqs_with_new_group_in_accu, ts)) + = requirements ti let_expr (reqs_with_empty_accu, ts) + new_group + = { tcg_type_coercions = reqs_with_new_group_in_accu.req_type_coercions, + tcg_position = let_expr_position } + reqs_with_new_group + = { reqs_with_new_group_in_accu & + req_type_coercion_groups = [new_group:reqs_with_new_group_in_accu.req_type_coercion_groups], + req_type_coercions = old_req_type_coercions } + = (res_type, opt_expr_ptr, (reqs_with_new_group, ts)) + instance requirements DynamicExpr where @@ -1579,7 +1599,9 @@ where possibly_accumulate_reqs_in_new_group position state_transition reqs_ts :== possibly_accumulate_reqs position reqs_ts where - possibly_accumulate_reqs position=:(FunPos _ _ _) (reqs=:{req_type_coercions=old_req_type_coercions}, ts) + possibly_accumulate_reqs NoPos reqs_ts + = state_transition reqs_ts + possibly_accumulate_reqs position (reqs=:{req_type_coercions=old_req_type_coercions}, ts) # reqs_with_empty_accu = { reqs & req_type_coercions = [] } (reqs_with_new_group_in_accu, ts) @@ -1592,8 +1614,6 @@ possibly_accumulate_reqs_in_new_group position state_transition reqs_ts req_type_coercion_groups = [new_group:reqs_with_new_group_in_accu.req_type_coercion_groups], req_type_coercions = old_req_type_coercions } = (reqs_with_new_group, ts) - possibly_accumulate_reqs _ reqs_ts - = state_transition reqs_ts // ..MW4 makeBase _ _ [] [] ts_var_heap @@ -1854,7 +1874,8 @@ where (type_heaps, expr_heap) = updateExpressionTypes clean_fun_type type_with_lifted_arg_types type_ptrs type_heaps expr_heap = ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error) // ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types) - = (fun_env, attr_var_env, type_heaps, expr_heap, specification_error clean_fun_type error) + # (printable_type, th_attrs) = beautifulizeAttributes clean_fun_type type_heaps.th_attrs + = (fun_env, attr_var_env, { type_heaps & th_attrs = th_attrs }, expr_heap, specification_error printable_type error) where add_lifted_arg_types arity_diff args1 args2 | arity_diff > 0 @@ -2088,15 +2109,17 @@ where */ unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin) unify_requirements_of_functions [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] ti subst heaps ts_error - # (subst, heaps, ts_error) = foldSt (unify_requirements_of_alternative ip_ident ti) req_type_coercion_groups (subst, heaps, ts_error) + # (subst, heaps, ts_error) = foldSt (unify_requirements_within_one_position ip_ident ti) req_type_coercion_groups (subst, heaps, ts_error) = unify_requirements_of_functions reqs_list ti subst heaps ts_error unify_requirements_of_functions [] ti subst heaps ts_error = (subst, heaps, ts_error) // MW4 added.. - unify_requirements_of_alternative :: !Ident !TypeInput !TypeCoercionGroup !(*{!Type}, !*TypeHeaps, !*ErrorAdmin) + unify_requirements_within_one_position :: !Ident !TypeInput !TypeCoercionGroup !(*{!Type}, !*TypeHeaps, !*ErrorAdmin) -> (*{!Type}, !*TypeHeaps, !*ErrorAdmin) - unify_requirements_of_alternative fun_symb ti {tcg_type_coercions, tcg_position} (subst, heaps, ts_error) + unify_requirements_within_one_position _ ti {tcg_type_coercions, tcg_position=NoPos} (subst, heaps, ts_error) + = unify_coercions tcg_type_coercions ti subst heaps ts_error + unify_requirements_within_one_position fun_symb ti {tcg_type_coercions, tcg_position} (subst, heaps, ts_error) # ts_error = setErrorAdmin (newPosition fun_symb tcg_position) ts_error = unify_coercions tcg_type_coercions ti subst heaps ts_error // ..MW4 |