Commit 6bd1fd28 authored by John van Groningen's avatar John van Groningen

implement pattern matching of strict, unboxed and overloaded lists

in let, with and where expressions
parent f9248303
......@@ -1866,7 +1866,17 @@ where
convertExpr (TupleSelect {ds_arity} n expr)
= beTupleSelectNode ds_arity n (convertExpr expr)
convertExpr (MatchExpr {glob_module, glob_object={ds_index,ds_arity}} expr)
= beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr)
| glob_module==cPredefinedModuleIndex
&& (let
pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
in
pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol)
= case expr of
App {app_args=[src_expr],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}
-> beMatchNode ds_arity (beOverloadedConsSymbol glob_module ds_index decons_module deconsindex) (convertExpr src_expr)
_
-> convertExpr expr
= beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr)
convertExpr (Conditional {if_cond=cond, if_then, if_else=Yes else})
= beIfNode (convertExpr cond) (convertExpr if_then) (convertExpr else)
......
......@@ -2374,6 +2374,9 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
if (strict_constructor){
struct arg **rhs_arg_p,*lhs_arg;
StateP constructor_arg_state_p;
#if STRICT_LISTS
StateS head_and_tail_states[2];
#endif
lhs_function_arg=NewArgument (constructor_node);
lhs_function_arg->arg_state=StrictState;
......@@ -2381,6 +2384,26 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
rhs_root=NewNode (TupleSymbol,NULL,constructor_arity);
rhs_arg_p=&rhs_root->node_arguments;
#if STRICT_LISTS
if (constructor_symbol->symb_kind==cons_symb && constructor_symbol->symb_head_strictness>1 || constructor_symbol->symb_tail_strictness){
constructor_symbol->symb_def->sdef_constructor->cl_state_p;
if (constructor_symbol->symb_head_strictness>1){
if (constructor_symbol->symb_head_strictness==4)
head_and_tail_states[0]=*constructor_symbol->symb_state_p;
else
head_and_tail_states[0]=StrictState;
} else
head_and_tail_states[0]=LazyState;
if (constructor_symbol->symb_tail_strictness)
head_and_tail_states[1]=StrictState;
else
head_and_tail_states[1]=LazyState;
constructor_arg_state_p=head_and_tail_states;
} else
#endif
constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p;
for_l (lhs_arg,constructor_node->node_arguments,arg_next){
......
......@@ -2754,7 +2754,7 @@ LabDef *unboxed_cons_label (SymbolP cons_symbol_p)
if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==SimpleState && BETWEEN (IntObj,FileObj,cons_symbol_p->symb_unboxed_cons_state_p->state_object))
return &unboxed_cons_labels[cons_symbol_p->symb_unboxed_cons_state_p->state_object-IntObj][cons_symbol_p->symb_tail_strictness];
else if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==RecordState){
unboxed_record_cons_lab.lab_mod=NULL;
unboxed_record_cons_lab.lab_mod=ExportLocalLabels ? CurrentModule : NULL;
unboxed_record_cons_lab.lab_pref=cons_symbol_p->symb_tail_strictness ? "r_Cons#!" : "r_Cons#";
unboxed_record_cons_lab.lab_issymbol=False;
unboxed_record_cons_lab.lab_name=cons_symbol_p->symb_unboxed_cons_state_p->state_record_symbol->sdef_ident->ident_name;
......@@ -3901,9 +3901,13 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
}
}
if (!symbol_arity_eq_one)
if (!symbol_arity_eq_one){
#if STRICT_LISTS
if (symbol->symb_kind==cons_symb && symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)
strict_constructor=1;
#endif
new_match_sdef=create_match_function (symbol,node->node_arity,strict_constructor);
else
} else
new_match_sdef=create_select_and_match_function (symbol,strict_constructor);
ConvertSymbolToDandNLabel (&name,&codelab,new_match_sdef);
......@@ -4009,7 +4013,42 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
*bsp_p += b_size;
AdjustTuple (a_size,b_size,asp_p,bsp_p,arity,demanded_state_array,constructor_args_state_p,a_size,b_size);
} else {
} else
#if STRICT_LISTS
if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)){
StateS head_and_tail_states[2];
if (symbol->symb_head_strictness>1){
if (symbol->symb_head_strictness==4)
head_and_tail_states[0]=*symbol->symb_state_p;
else
head_and_tail_states[0]=StrictState;
} else
head_and_tail_states[0]=LazyState;
if (symbol->symb_tail_strictness)
head_and_tail_states[1]=StrictState;
else
head_and_tail_states[1]=LazyState;
if (symbol->symb_head_strictness==4){
DetermineSizeOfState (head_and_tail_states[0],&a_size,&b_size);
++a_size;
GenReplRArgs (a_size,b_size);
*asp_p -= 1-a_size;
*bsp_p += b_size;
AdjustTuple (a_size,b_size,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,a_size,b_size);
} else {
GenReplArgs (2,2);
*asp_p -= 1-2;
AdjustTuple (2,0,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,2,0);
}
} else
#endif
{
*asp_p-=1;
UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array);
}
......
......@@ -58,9 +58,9 @@ get_unboxed_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!In
get_unboxed_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x}
# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
# (cons_u_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_u].pds_def
# (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def
# (decons_u_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_u]
# decons_u_index=decons_u_symbol.pds_def
# (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def
# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
= (stdStrictLists_index,cons_u_index,decons_u_index,nil_u_index,predefined_idents.[PD_decons_u],cs)
......@@ -71,18 +71,18 @@ make_unboxed_list type_symbol expr_heap cs
# decons_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
= (unboxed_list,decons_expr,expr_heap,cs)
get_unboxed_tail_strict_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
get_unboxed_tail_strict_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x}
get_unboxed_tail_strict_list_indices_and_decons_uts_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs=:{cs_predef_symbols,cs_x}
# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
# (cons_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_uts].pds_def
# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
# (decons_uts_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_uts]
# decons_uts_index=decons_uts_symbol.pds_def
# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
= (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,predefined_idents.[PD_decons_uts],cs)
make_unboxed_tail_strict_list type_symbol expr_heap cs
# (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_u_ident cs
# (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs
# unboxed_list=UnboxedTailStrictList type_symbol stdStrictLists_index decons_uts_index nil_uts_index
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
......@@ -92,9 +92,9 @@ get_overloaded_list_indices_and_decons_ident :: *CheckState -> (!Index,!Index,!I
get_overloaded_list_indices_and_decons_ident cs=:{cs_predef_symbols,cs_x}
# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
# (cons_index,cs_predef_symbols)=cs_predef_symbols![PD_cons].pds_def
# (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def
# (decons_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons]
# decons_index=decons_symbol.pds_def
# (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def
# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
= (stdStrictLists_index,cons_index,decons_index,nil_index,predefined_idents.[PD_decons],cs)
......@@ -1808,7 +1808,28 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo
position var_store expr_heap e_info cs
-> (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs)
# (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex ds_arity) PD_PredefinedModule STE_Constructor ds_arity cs
(match_var, match_bind, var_store, expr_heap)
# (src_expr,expr_heap,cs) = add_decons_call_for_overloaded_lists src_expr expr_heap cs
with
add_decons_call_for_overloaded_lists src_expr expr_heap cs
| glob_module==cPredefinedModuleIndex
# pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
| pd_cons_index==PD_UnboxedConsSymbol
# (stdStrictLists_index,_,decons_u_index,_,decons_u_ident,cs) = get_unboxed_list_indices_and_decons_u_ident cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_u_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}
= (decons_u_expr,expr_heap,cs)
| pd_cons_index==PD_UnboxedTailStrictConsSymbol
# (stdStrictLists_index,_,decons_uts_index,_,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_uts_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}
= (decons_uts_expr,expr_heap,cs)
| pd_cons_index==PD_OverloadedConsSymbol
# (stdStrictLists_index,_,decons_index,_,decons_ident,cs) = get_overloaded_list_indices_and_decons_ident cs
# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
# decons_expr = App {app_symb={symb_name=decons_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}
= (decons_expr,expr_heap,cs)
= (src_expr,expr_heap,cs)
# (match_var, match_bind, var_store, expr_heap)
= bind_match_expr (MatchExpr 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
......
......@@ -1547,17 +1547,23 @@ where
attributedBasicType {box=type} ts=:{ts_attr_store}
= ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = type}, {ts & ts_attr_store = inc ts_attr_store})
requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) (reqs, ts)
# cp = CP_Expression expr
({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts
(e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts)
reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions,
req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] }
ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap }
| ds_arity<>1
# tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity
= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts))
= ( hd tst_args, No, (reqs, ts))
requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) reqs_ts=:(reqs, ts)
| glob_module==cPredefinedModuleIndex
&& (let
pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
in
pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol)
= requirements ti expr reqs_ts
# cp = CP_Expression expr
({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts
(e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts)
reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions,
req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] }
ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap }
| ds_arity<>1
# tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity
= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts))
= ( hd tst_args, No, (reqs, ts))
requirements _ (AnyCodeExpr _ _ _) (reqs, ts)
# (fresh_v, ts) = freshAttributedVariable ts
......
Markdown is supported
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