Commit e45216c2 authored by John van Groningen's avatar John van Groningen
Browse files

adapt arguments and result separately, instead of adapting the function

parent 81bf4d1c
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment