Commit 23dcc68a authored by John van Groningen's avatar John van Groningen
Browse files

fix convertTypeCode for TCE_Selector, required if TC is used in the

context of a class definition (e.g. class C a | TC a)
parent 81b01bd8
...@@ -11,7 +11,10 @@ extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in St ...@@ -11,7 +11,10 @@ extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in St
import type_io; import type_io;
:: TypeCodeVariableInfo = TCI_TypeVar !Expression | TCI_TypePatternVar !Expression :: TypeCodeVariableInfo = TCI_TypeVar !Expression
| TCI_TypePatternVar !Expression
| TCI_SelectionsTypePatternVar ![(Expression,[Selection])]
:: DynamicValueAliasInfo :== BoundVar :: DynamicValueAliasInfo :== BoundVar
:: *ConversionState = :: *ConversionState =
...@@ -182,31 +185,37 @@ instance convertDynamics TransformedBody where ...@@ -182,31 +185,37 @@ instance convertDynamics TransformedBody where
// = writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) var_heap // = writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) var_heap
collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState) collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
collect_global_type_pattern_var {fv_info_ptr} (l, subst, ci) collect_global_type_pattern_var {fv_info_ptr} (let_binds, subst, ci)
# (var_info, ci_var_heap) # (var_info, ci_var_heap) = readPtr fv_info_ptr ci.ci_var_heap
= readPtr fv_info_ptr ci.ci_var_heap ci = {ci & ci_var_heap = ci_var_heap}
# ci = case var_info of
= {ci & ci_var_heap = ci_var_heap} VI_TypeCodeVariable (TCI_TypePatternVar tpv)
= case var_info of # type_code = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
VI_TypeCodeVariable (TCI_TypePatternVar tpv) -> bind_global_type_pattern_var tpv type_code let_binds subst ci
# (bind_global_tpv_symb, ci) VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)
= getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci -> collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci
# type_code _
= {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} -> (let_binds, subst, ci)
# (unify_subst_var, ci) where
= newVariable "gtpv_subst" VI_Empty ci bind_global_type_pattern_var tpv type_code let_binds subst ci
unify_subst_fv # (bind_global_tpv_symb, ci)
= varToFreeVar unify_subst_var 1 = getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci
# let_bind (unify_subst_var, ci) = newVariable "gtpv_subst" VI_Empty ci
= { lb_src = App { app_symb = bind_global_tpv_symb, let_bind
app_args = [tpv, Var type_code, Var unify_subst_var], = { lb_src = App { app_symb = bind_global_tpv_symb,
app_info_ptr = nilPtr } app_args = [tpv, type_code, Var unify_subst_var],
, lb_dst = varToFreeVar subst 1 app_info_ptr = nilPtr }
, lb_position = NoPos , lb_dst = varToFreeVar subst 1
} , lb_position = NoPos }
-> ([let_bind:l], unify_subst_var, ci) = ([let_bind:let_binds], unify_subst_var, ci)
_
-> (l, subst, ci) collect_global_type_pattern_var_selections [(tpv,selections):tc_selections] fv_info_ptr let_binds subst ci
# dictionary = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
type_code = Selection NormalSelector dictionary selections
(let_binds,subst,ci) = bind_global_type_pattern_var tpv type_code let_binds subst ci
= collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci
collect_global_type_pattern_var_selections [] fv_info_ptr let_binds subst ci
= (let_binds,subst,ci)
share_init_subst :: BoundVar [LetBind] Expression *ConversionState share_init_subst :: BoundVar [LetBind] Expression *ConversionState
-> (Expression, *ConversionState) -> (Expression, *ConversionState)
...@@ -551,40 +560,30 @@ convertPatternTypeCode cinp tce ci ...@@ -551,40 +560,30 @@ convertPatternTypeCode cinp tce ci
= (type_code, binds, ci) = (type_code, binds, ci)
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState) convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
-> (!Expression, (!Bool, ![LetBind], !*ConversionState)) -> (!Expression, !(!Bool, ![LetBind], !*ConversionState))
convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap}) convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
# (var_info, ci_var_heap) # (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
= readPtr var_info_ptr ci_var_heap ci = {ci & ci_var_heap = ci_var_heap}
ci
= {ci & ci_var_heap = ci_var_heap}
= case var_info of = case var_info of
VI_TypeCodeVariable (TCI_TypeVar tv) VI_TypeCodeVariable (TCI_TypeVar tv)
-> (tv, (has_var, binds, ci)) -> (tv, (has_var, binds, ci))
VI_TypeCodeVariable (TCI_TypePatternVar tpv) VI_TypeCodeVariable (TCI_TypePatternVar tpv)
-> (tpv, (True, binds, ci)) -> (tpv, (True, binds, ci))
_ _
# (expr, ci) # (expr, ci) = createTypePatternVariable ci
= createTypePatternVariable ci # ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
# ci
= {ci & ci_var_heap
= writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
-> (expr, (True, binds, ci)) -> (expr, (True, binds, ci))
convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap}) convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
# (var_info, ci_var_heap) # (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
= readPtr var_info_ptr ci_var_heap ci = {ci & ci_var_heap = ci_var_heap}
ci
= {ci & ci_var_heap = ci_var_heap}
= case var_info of = case var_info of
VI_TypeCodeVariable (TCI_TypeVar tv) VI_TypeCodeVariable (TCI_TypeVar tv)
-> (tv, (has_var, binds, ci)) -> (tv, (has_var, binds, ci))
VI_TypeCodeVariable (TCI_TypePatternVar tpv) VI_TypeCodeVariable (TCI_TypePatternVar tpv)
-> (tpv, (True, binds, ci)) -> (tpv, (True, binds, ci))
_ _
# (expr, ci) # (expr, ci) = createTypePatternVariable ci
= createTypePatternVariable ci # ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
# ci
= {ci & ci_var_heap
= writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
-> (expr, (True, binds, ci)) -> (expr, (True, binds, ci))
convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci) convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci)
...@@ -720,9 +719,24 @@ convertTypeCode pattern cinp (TCE_UnqType type) (has_var, binds, ci) ...@@ -720,9 +719,24 @@ convertTypeCode pattern cinp (TCE_UnqType type) (has_var, binds, ci)
app_info_ptr = nilPtr}, (has_var, binds, ci)) app_info_ptr = nilPtr}, (has_var, binds, ci))
convertTypeCode pattern cinp (TCE_Selector selections var_info_ptr) st convertTypeCode pattern cinp (TCE_Selector selections var_info_ptr) st
# (var, st) # (has_var, binds, ci) = st
= convertTypeCode pattern cinp (TCE_Var var_info_ptr) st (var_info, ci_var_heap) = readPtr var_info_ptr ci.ci_var_heap
= (Selection NormalSelector var selections, st) ci = {ci & ci_var_heap = ci_var_heap}
= case var_info of
VI_TypeCodeVariable (TCI_TypeVar tv)
-> abort "convertTypeCode TCE_Selector"
VI_TypeCodeVariable (TCI_TypePatternVar tpv)
-> abort "convertTypeCode TCE_Selector"
VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)
# (var, ci) = createTypePatternVariable ci
tc_selections = [(var,selections):tc_selections]
ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)) ci.ci_var_heap}
-> (var, (True, binds, ci))
_
# (var, ci) = createTypePatternVariable ci
tc_selections = [(var,selections)]
ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)) ci.ci_var_heap}
-> (var, (True, binds, ci))
createTypePatternVariable :: !*ConversionState -> (!Expression, !*ConversionState) createTypePatternVariable :: !*ConversionState -> (!Expression, !*ConversionState)
createTypePatternVariable ci createTypePatternVariable ci
......
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