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

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
......
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