diff options
| -rw-r--r-- | frontend/check.icl | 40 | ||||
| -rw-r--r-- | frontend/parse.icl | 14 | ||||
| -rw-r--r-- | frontend/postparse.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 4 | ||||
| -rw-r--r-- | frontend/trans.icl | 32 | ||||
| -rw-r--r-- | frontend/transform.dcl | 1 | ||||
| -rw-r--r-- | frontend/transform.icl | 7 |
8 files changed, 60 insertions, 44 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 7720e0a..84b8b2e 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -755,7 +755,7 @@ checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_m :: ArrayPattern = { ap_opt_var :: !Optional (Bind Ident VarInfoPtr) , ap_array_var :: !FreeVar - , ap_selections :: ![Bind FreeVar ParsedExpr] + , ap_selections :: ![Bind FreeVar [ParsedExpr]] } buildPattern mod_index (APK_Constructor type_index) cons_symb args opt_var ps e_info cs @@ -967,7 +967,7 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter { ps & ps_var_heap = ps_var_heap }, e_info, cs) where check_array_selection def_level bind=:{bind_dst} states - = check_rhs def_level bind (check_index_expr bind_dst states) + = check_rhs def_level bind (foldSt check_index_expr bind_dst states) check_index_expr (PE_Ident {id_name}) states | isLowerCaseName id_name @@ -1895,7 +1895,7 @@ where = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr 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 } (_, array_pattern_binds, free_vars, e_state, e_info, cs) // XXX arrays currently not strictly evaluated - = foldSt (buildSelectCalls e_input) array_patterns ([], [], free_vars, e_state, e_info, cs) + = foldSt (buildSelections e_input) array_patterns ([], [], free_vars, e_state, e_info, cs) all_binds = [(seq_let.ndwl_strict, let_binds), (nOT_STRICT, array_pattern_binds) : binds] with nOT_STRICT = False = (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs) check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs @@ -2000,7 +2000,7 @@ addArraySelections [] rhs_expr free_vars e_input e_state e_info cs = (rhs_expr, free_vars, e_state, e_info, cs) addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs # (let_strict_binds, let_lazy_binds, free_vars, e_state, e_info, cs) - = foldSt (buildSelectCalls e_input) array_patterns ([], [], free_vars, e_state, e_info, cs) + = foldSt (buildSelections e_input) array_patterns ([], [], free_vars, 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, @@ -2011,7 +2011,7 @@ addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs , cs ) -buildSelectCalls e_input {ap_opt_var, ap_array_var, ap_selections} +buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} (strict_binds, lazy_binds, free_vars, e_state, e_info, cs) # (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) = foldSt (build_sc e_input) ap_selections @@ -2027,7 +2027,7 @@ buildSelectCalls e_input {ap_opt_var, ap_array_var, ap_selections} no -> (lazy_binds, e_state) = (strict_binds, lazy_binds, free_vars, e_state, e_info, cs) where - build_sc e_input {bind_dst, bind_src=array_element_var} (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) + build_sc e_input {bind_dst=parsed_index_exprs, bind_src=array_element_var} (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) # (var_for_uselect_result, es_var_heap) = allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap (new_array_var, es_var_heap) @@ -2036,21 +2036,27 @@ buildSelectCalls e_input {ap_opt_var, ap_array_var, ap_selections} = allocate_bound_var ap_array_var e_state.es_expr_heap (bound_var_for_uselect_result, es_expr_heap) = allocate_bound_var var_for_uselect_result es_expr_heap - (new_expr_ptr, es_expr_heap) - = newPtr EI_Empty es_expr_heap + dimension = length parsed_index_exprs + (new_expr_ptrs, es_expr_heap) + = mapSt newPtr (repeatn dimension EI_Empty) es_expr_heap (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex 2) PD_PredefinedModule STE_Constructor 2 cs - (glob_select_symb, cs) - = getPredefinedGlobalSymbol PD_UnqArraySelectFun PD_StdArray STE_Member 2 cs + (glob_select_symb, opt_tuple_type, cs) + = case dimension of + 1 # (unq_select_symb, cs) = getPredefinedGlobalSymbol PD_UnqArraySelectFun PD_StdArray STE_Member 2 cs + -> (unq_select_symb, No, cs) + _ # (select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs + (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs + -> (select_symb, Yes tuple_type, cs) e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap } - (index_expr, free_vars, e_state, e_info, cs) - = checkExpression free_vars bind_dst e_input e_state e_info cs - selection - = ArraySelection glob_select_symb new_expr_ptr index_expr + (index_exprs, (free_vars, e_state, e_info, cs)) + = mapSt (check_index_expr e_input) parsed_index_exprs (free_vars, e_state, e_info, cs) + selections + = [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ] = ( new_array_var , strict_binds - , [ {bind_dst = var_for_uselect_result, bind_src = Selection No (Var bound_array_var) [selection]} + , [ {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)} : lazy_binds @@ -2061,6 +2067,10 @@ buildSelectCalls e_input {ap_opt_var, ap_array_var, ap_selections} , cs ) + check_index_expr e_input parsed_index_expr (free_vars, e_state, e_info, cs) + # (index_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars parsed_index_expr e_input e_state e_info cs + = (index_expr, (free_vars, e_state, e_info, cs)) + allocate_free_var ident var_heap # (new_var_info_ptr, var_heap) = newPtr VI_Empty var_heap = ({ fv_def_level = NotALevel, fv_name = ident, fv_info_ptr = new_var_info_ptr, fv_count = 0 }, var_heap) diff --git a/frontend/parse.icl b/frontend/parse.icl index 2187267..94d18a0 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -2525,12 +2525,20 @@ where = ([ assign ], tokenBack pState) where want_array_assignment is_pattern pState - # (index_exp, pState) = wantExpression cIsNotAPattern pState - pState = wantToken FunctionContext "array assignment" SquareCloseToken pState + # (index_exprs, pState) = want_index_exprs pState pState = wantToken FunctionContext "array assignment" EqualToken pState (pattern_exp, pState) = wantExpression is_pattern pState - = ({bind_dst = index_exp, bind_src = pattern_exp}, pState) + = ({bind_dst = index_exprs, bind_src = pattern_exp}, pState) + want_index_exprs pState + # (index_expr, pState) = wantExpression cIsNotAPattern pState + (token, pState) = nextToken GeneralContext pState + | token==CommaToken + # (index_exprs, pState) = want_index_exprs pState + = ([index_expr:index_exprs], pState) + | token==SquareCloseToken + = ([index_expr], pState) + = ([], parseError "" (Yes token) "] or ," pState) /** End of definitions **/ diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 75f0d69..f7aa03f 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -614,11 +614,11 @@ transformSequence (SQ_From frm) transformSequence (SQ_FromTo frm to) = predef PD_FromTo ` frm ` to -transformArrayUpdate :: ParsedExpr [ElemAssignment] PredefinedIdents -> ParsedExpr +transformArrayUpdate :: ParsedExpr [Bind ParsedExpr ParsedExpr] PredefinedIdents -> ParsedExpr transformArrayUpdate expr updates pi = foldr (update pi (predef PD_ArrayUpdateFun)) expr updates where - update :: PredefinedIdents (PredefinedIdents -> ParsedExpr) ElemAssignment ParsedExpr -> ParsedExpr + update :: PredefinedIdents (PredefinedIdents -> ParsedExpr) (Bind ParsedExpr ParsedExpr) ParsedExpr -> ParsedExpr update pi updateIdent {bind_src=value, bind_dst=index} expr = (updateIdent ` expr ` index ` value) pi diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 0d3d7eb..5417dfe 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -949,7 +949,7 @@ cIsArrayGenerator :== False :: FieldAssignment :== Bind ParsedExpr Ident -:: ElemAssignment :== Bind ParsedExpr ParsedExpr +:: ElemAssignment :== Bind ParsedExpr [ParsedExpr] cIsStrict :== True diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 898eaac..ee9303b 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -913,7 +913,7 @@ cIsArrayGenerator :== False :: FieldAssignment :== Bind ParsedExpr Ident -:: ElemAssignment :== Bind ParsedExpr ParsedExpr +:: ElemAssignment :== Bind ParsedExpr [ParsedExpr] //:: NodeDef :== Bind ParsedExpr ParsedExpr @@ -1331,7 +1331,7 @@ where = file write_binds file [bind : binds] = write_binds (file <<< bind <<< '\n') binds - (<<<) file (Case {case_expr,case_guards,case_default=No}) + (<<<) file (Case {case_expr,case_guards,case_default=No}) = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards (<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr}) = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t-> " <<< def_expr diff --git a/frontend/trans.icl b/frontend/trans.icl index c9cc4ab..5b26a53 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -526,7 +526,7 @@ where # (VI_AccVar _ arg_position, var_heap) = readPtr var_info_ptr var_heap ({cc_size, cc_args, cc_linear_bits},class_env) = class_env![fun_index] (aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap - | /*XXX*/arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==cActive) && cc_linear_bits!!arg_position + | arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==cActive) && cc_linear_bits!!arg_position // mark non multimatch cases whose case_expr is an active linear function argument # aci = { aci_params = [], aci_opt_unfolder = No, aci_free_vars=No, aci_linearity_of_patterns = aci_linearity_of_patterns } = ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, @@ -869,7 +869,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf = ([guard_expr], ti) lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=ti.ti_cleanup_info, us_subst_vars = False, us_handle_aci_free_vars = LeaveThem } + us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = LeaveThem } (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards us (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap @@ -899,7 +899,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=ti.ti_cleanup_info, us_subst_vars = True, us_handle_aci_free_vars = LeaveThem } + us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = LeaveThem } (unfolded_expr, unfold_state) = unfold new_expr unfold_state (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } (unfold_state_to_ti unfold_state ti) = (Yes final_expr, ti) @@ -935,7 +935,6 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf match_and_instantiate _ cons_index app_args [] default_expr ro ti = transform default_expr { ro & ro_root_case_mode = NotRootCase } ti - possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced} // | False->>("possibly_generate_case_function") // = undef @@ -1000,7 +999,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti types_from_outer_fun = [ st_arg \\ st_arg <- st_args & used <- used_mask | used ] nr_of_lifted_vars = fun_arity-(length types_from_outer_fun) (lifted_types, ti_var_heap) = mapSt get_type_of_local_var (take nr_of_lifted_vars ro_fun_args) ti.ti_var_heap - (EI_CaseType {ct_result_type}, ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap + (EI_CaseType {ct_result_type}, ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap (form_vars, ti_var_heap) = mapSt bind_to_fresh_var ro_fun_args ti_var_heap arg_types = lifted_types++types_from_outer_fun type_variables = getTypeVars [ct_result_type:arg_types] @@ -1009,7 +1008,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti (fresh_arg_types, ti_type_heaps) = substitute arg_types { th_vars = th_vars, th_attrs = th_attrs } (fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps, - us_cleanup_info=ti.ti_cleanup_info, us_subst_vars = True, us_handle_aci_free_vars = SubstituteThem } + us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = SubstituteThem } (copied_expr, {us_var_heap=ti_var_heap, us_symbol_heap=ti_symbol_heap, us_cleanup_info=ti_cleanup_info, us_opt_type_heaps = Yes ti_type_heaps}) = unfold new_expr us fun_type = { st_vars = fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity, st_result = fresh_result_type, @@ -1226,13 +1225,7 @@ searchInstance prods1 (II_Node prods2 fun_info_ptr left right) = searchInstance prods1 right = searchInstance prods1 left */ -/* Fragen/to do: - - wird die neu generierte Funktion bereits in der folgenden Transformation gebraucht ? - Antwort: Ich verbiete das einfach, indem generierte funktionen,deren Koerper "Expanding" nicht als Produzent - klassifiziert werden. - - wie wird die neu generierte Funktion klassifiziert ? Antwort: Die Klassifikationen werden weitervererbt (auch die linear_bits) - - type attributes -*/ + generateFunction :: !FunDef !ConsClasses !{! Producer} !FunctionInfoPtr !ReadOnlyTI !*TransformInfo -> (!Index, !Int, !*TransformInfo) generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}} {cc_args,cc_linear_bits} prods fun_def_ptr ro @@ -1263,7 +1256,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi gf_cons_args = {cc_args = new_cons_args, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits} } ti_fun_heap = writePtr fun_def_ptr (FI_Function new_gen_fd) ti_fun_heap us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps, - us_cleanup_info=ti_cleanup_info, us_subst_vars = True, us_handle_aci_free_vars = RemoveThem } + us_cleanup_info=ti_cleanup_info, us_handle_aci_free_vars = RemoveThem } (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes type_heaps, us_cleanup_info}) = unfold tb_rhs us ro = { ro & ro_root_case_mode = case tb_rhs of {Case _ -> RootCase; _ -> NotRootCase}, ro_fun= { symb_name = fd.fun_symb, symb_kind = SK_GeneratedFunction fun_def_ptr ti_next_fun_nr, symb_arity = fun_arity}, @@ -2103,7 +2096,7 @@ where freeVariables (Selection _ expr selectors) fvi = freeVariables expr fvi freeVariables (Update expr1 selectors expr2) fvi - = freeVariables expr2 (freeVariables expr1 fvi) + = freeVariables expr2 (freeVariables selectors (freeVariables expr1 fvi)) freeVariables (RecordUpdate cons_symbol expression expressions) fvi = free_variables_of_record_expression expression expressions fvi where @@ -2130,6 +2123,15 @@ where freeVariables _ fvi = fvi +instance freeVariables Selection +where + freeVariables (RecordSelection _ _) fvi + = fvi + freeVariables (ArraySelection _ _ expr) fvi + = freeVariables expr fvi + freeVariables (DictionarySelection dict_var selections _ expr) fvi + = freeVariables dict_var (freeVariables selections (freeVariables expr fvi)) + removeVariables global_variables var_heap = foldSt remove_variable global_variables ([], var_heap) where diff --git a/frontend/transform.dcl b/frontend/transform.dcl index 8e0f782..6d3a81c 100644 --- a/frontend/transform.dcl +++ b/frontend/transform.dcl @@ -17,7 +17,6 @@ partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap , us_symbol_heap :: !.ExpressionHeap , us_opt_type_heaps :: !.Optional .TypeHeaps , us_cleanup_info :: ![ExprInfoPtr] - , us_subst_vars :: !Bool , us_handle_aci_free_vars :: !AciFreeVarHandleMode } diff --git a/frontend/transform.icl b/frontend/transform.icl index 75b8972..a7ce914 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -165,7 +165,6 @@ where , us_symbol_heap :: !.ExpressionHeap , us_opt_type_heaps :: !.Optional .TypeHeaps , us_cleanup_info :: ![ExprInfoPtr] - , us_subst_vars :: !Bool // XXX currently not used , us_handle_aci_free_vars :: !AciFreeVarHandleMode } @@ -191,8 +190,6 @@ where unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) unfoldVariable var=:{var_name,var_info_ptr} us -// XXX | not us.us_subst_vars -// = (Var var, us) #! (var_info, us) = readVarInfo var_info_ptr us = case var_info of VI_Expression expr @@ -497,7 +494,7 @@ examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} args fun_defs (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table}) # (let_binds, var_heap) = bind_expressions tb_args args [] es_var_heap us = { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_opt_type_heaps = No, us_cleanup_info = [], - us_subst_vars = True, us_handle_aci_free_vars = RemoveThem } + us_handle_aci_free_vars = RemoveThem } (result_expr, {us_symbol_heap,us_var_heap}) = unfold tb_rhs us (calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls fun_defs es_symbol_table | isEmpty let_binds @@ -861,7 +858,7 @@ where = (expr, var_heap, symbol_heap) replace_variables vars expr ap_vars var_heap symbol_heap # us = { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=[], us_subst_vars = True, us_handle_aci_free_vars = RemoveThem } + us_cleanup_info=[], us_handle_aci_free_vars = RemoveThem } (expr, us) = unfold expr us = (expr, us.us_var_heap, us.us_symbol_heap) |