diff options
| author | johnvg | 2011-02-28 13:30:18 +0000 |
|---|---|---|
| committer | johnvg | 2011-02-28 13:30:18 +0000 |
| commit | 7270e248d28e934dbd494622ef9c1bd6c6ced80f (patch) | |
| tree | e3e5665447b3b4e97e1224fa3a376c56ae8f7c71 /frontend/generics1.icl | |
| parent | git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1866 1f8540f1-abd... (diff) | |
adapt arguments and result separately, instead of adapting the function
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1867 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
Diffstat (limited to 'frontend/generics1.icl')
| -rw-r--r-- | frontend/generics1.icl | 66 |
1 files changed, 49 insertions, 17 deletions
diff --git a/frontend/generics1.icl b/frontend/generics1.icl index db32440..27b46b7 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -1893,7 +1893,7 @@ buildGenericCaseBody :: !FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin -> (!FunctionBody, !FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_ident,gc_kind,gc_generic} st predefs +buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_kind,gc_generic} st predefs funs_and_groups td_infos modules heaps error #! (gen_def, modules) = modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index] #! (td_info=:{tdi_gen_rep}, td_infos) = td_infos![type_index.glob_module,type_index.glob_object] @@ -1914,15 +1914,13 @@ buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_iden _ -> (arg_vars,heaps) - #! (adaptor_expr, funs_and_groups, modules, td_infos, heaps, error) - = build_adaptor_expr gc gen_def gen_type_rep funs_and_groups modules td_infos heaps error + #! (optional_adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, modules, td_infos, heaps, error) + = build_adaptor_expr gc gen_def gen_type_rep original_arg_exprs funs_and_groups modules td_infos heaps error #! (specialized_expr, funs_and_groups, td_infos, heaps, error) = build_specialized_expr gc gtr_type td_args generated_arg_exprs funs_and_groups td_infos heaps error - #! body_expr - = build_body_expr adaptor_expr specialized_expr original_arg_exprs - + # body_expr = build_body_expr optional_adaptor_expr specialized_expr adapted_arg_exprs original_arg_exprs = (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, funs_and_groups, td_infos, modules, heaps, error) where build_generic_info_arg heaps=:{hp_var_heap} @@ -1944,7 +1942,7 @@ where // adaptor that converts a function for the generic representation into a // function for the type itself - build_adaptor_expr {gc_ident, gc_pos} {gen_type, gen_vars, gen_info_ptr} {gtr_iso} funs_and_groups modules td_infos heaps error + build_adaptor_expr {gc_ident, gc_pos} {gen_type, gen_vars, gen_info_ptr} {gtr_iso} original_arg_exprs funs_and_groups modules td_infos heaps error #! (var_kinds, heaps) = get_var_kinds gen_info_ptr heaps #! non_gen_var_kinds = drop (length gen_vars) var_kinds @@ -1961,11 +1959,12 @@ where #! (struct_gen_type, heaps) = simplify_bimap_GenTypeStruct gen_vars struct_gen_type heaps - #! (adaptor_expr, funs_and_groups, heaps, error) - = specialize_generic_from_bimap {gi_module=bimap_module,gi_index=bimap_index} struct_gen_type spec_env bimap_ident gc_pos main_module_index predefs + # bimap_gi = {gi_module=bimap_module,gi_index=bimap_index} + #! (adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, heaps, error) + = specialize_generic_from_bimap bimap_gi struct_gen_type spec_env bimap_ident gc_pos original_arg_exprs main_module_index predefs funs_and_groups heaps error - = (adaptor_expr, funs_and_groups, modules, td_infos, heaps, error) + = (adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, modules, td_infos, heaps, error) where {pds_module = bimap_module, pds_def=bimap_index} = predefs.[PD_GenericBimap] bimap_ident = predefined_idents.[PD_GenericBimap] @@ -2023,10 +2022,22 @@ where = (expr,funs_and_groups,td_infos,heaps,error) // the body expression - build_body_expr adaptor_expr specialized_expr [] + build_body_expr No specialized_expr [] [] + = specialized_expr + build_body_expr No specialized_expr [] original_arg_exprs + = specialized_expr @ original_arg_exprs + build_body_expr No specialized_expr adapted_arg_exprs [] + = specialized_expr @ adapted_arg_exprs + build_body_expr No specialized_expr adapted_arg_exprs original_arg_exprs + = specialized_expr @ (adapted_arg_exprs++original_arg_exprs) + build_body_expr (Yes adaptor_expr) specialized_expr [] [] = adaptor_expr @ [specialized_expr] - build_body_expr adaptor_expr specialized_expr original_arg_exprs + build_body_expr (Yes adaptor_expr) specialized_expr [] original_arg_exprs = (adaptor_expr @ [specialized_expr]) @ original_arg_exprs + build_body_expr (Yes adaptor_expr) specialized_expr adapted_arg_exprs [] + = adaptor_expr @ [specialized_expr @ adapted_arg_exprs] + build_body_expr (Yes adaptor_expr) specialized_expr adapted_arg_exprs original_arg_exprs + = (adaptor_expr @ [specialized_expr @ adapted_arg_exprs]) @ original_arg_exprs buildGenericCaseBody main_module_index {gc_ident,gc_pos} st predefs funs_and_groups td_infos modules heaps error # error = reportError gc_ident gc_pos "cannot specialize to this type" error @@ -2391,18 +2402,39 @@ specialize_generic_from_bimap :: ![(TypeVar, Expression)] // specialization environment !Ident // generic/generic case !Position // of generic case + ![Expression] !Index // main_module index !PredefinedSymbols !FunsAndGroups !*Heaps !*ErrorAdmin - -> (!Expression, + -> (!Optional Expression, ![Expression], ![Expression], !FunsAndGroups,!*Heaps,!*ErrorAdmin) -specialize_generic_from_bimap gen_index type spec_env gen_ident gen_pos main_module_index predefs funs_and_groups heaps error +specialize_generic_from_bimap gen_index type spec_env gen_ident gen_pos arg_exprs main_module_index predefs funs_and_groups heaps error #! heaps = set_tvs spec_env heaps - #! (adaptor_expr, (funs_and_groups, heaps, error)) - = specialize_from type (funs_and_groups, heaps, error) + #! (optional_adaptor_expr, adapted_arg_exprs, arg_exprs, (funs_and_groups, heaps, error)) + = specialize_args_and_result arg_exprs type (funs_and_groups, heaps, error) # heaps = clear_tvs spec_env heaps - = (adaptor_expr, funs_and_groups, heaps, error) + = (optional_adaptor_expr, adapted_arg_exprs, arg_exprs, funs_and_groups, heaps, error) where + specialize_args_and_result [arg_expr:arg_exprs] (GTSArrow arg_type args_type) st + # (adapted_arg_expr,st) + = adapt_arg arg_type arg_expr st + (adaptor_expr,adapted_arg_exprs,arg_exprs,st) + = specialize_args_and_result arg_exprs args_type st + = (adaptor_expr,[adapted_arg_expr:adapted_arg_exprs],arg_exprs,st) + specialize_args_and_result arg_exprs type st + | is_bimap_id type + = (No, [], arg_exprs, st) + # (adaptor_expr,st) + = specialize_from type st + = (Yes adaptor_expr,[],arg_exprs,st) + + adapt_arg arg_type arg_expr st + | is_bimap_id arg_type + = (arg_expr,st) + # (arg_adaptor_expr,st) + = specialize_to arg_type st + = (arg_adaptor_expr @ [arg_expr],st) + specialize_from (GTSArrow (GTSAppCons KindConst []) y) st = specialize_from_arrow_arg_id y st specialize_from (GTSArrow GTSAppConsBimapKindConst y) st |