diff options
Diffstat (limited to 'backendC')
| -rw-r--r-- | backendC/CleanCompilerSources/pattern_match_2.c | 986 |
1 files changed, 986 insertions, 0 deletions
diff --git a/backendC/CleanCompilerSources/pattern_match_2.c b/backendC/CleanCompilerSources/pattern_match_2.c new file mode 100644 index 0000000..e370790 --- /dev/null +++ b/backendC/CleanCompilerSources/pattern_match_2.c @@ -0,0 +1,986 @@ +/* + File: pattern_match.c + Author: John van Groningen +*/ + +#define DEBUG_OUTPUT 0 + +#if defined (applec) || defined (__MWERKS__) || defined (__MRC__) +# define __ppc__ +#endif + +#include <stdio.h> + +#include "compiledefines.h" +#include "types.t" +#include "syntaxtr.t" +#include "pattern_match.h" +#include "buildtree.h" +#include "comsupport.h" +#include "statesgen.h" +#include "settings.h" +#include "codegen_types.h" + +#define for_l(v,l,n) for(v=(l);v!=NULL;v=v->n) + +static void error_in_function (char *m) +{ + ErrorInCompiler ("",m,""); +} + +#if DEBUG_OUTPUT +char *node_id_name (NodeId node_id) +{ + static char node_id_name_s[65]; + + if (node_id->nid_ident!=NULL && node_id->nid_ident->ident_name!=NULL) + return node_id->nid_ident->ident_name; + else { + sprintf (node_id_name_s,"i_%lx",(long)node_id); + return node_id_name_s; + } +} +#endif + +static NodeP new_switch_node (NodeIdP node_id,NodeP case_node,StateP state_p,NodeS ***root_l) +{ + NodeP switch_node; + + switch_node=CompAllocType (NodeS); + + switch_node->node_kind=SwitchNode; + switch_node->node_node_id=node_id; + switch_node->node_arity=1; + switch_node->node_arguments=NewArgument (case_node); + switch_node->node_state=*state_p; + +#if DEBUG_OUTPUT + printf ("dec %s %d\n",node_id_name (node_id),node_id->nid_refcount); +#endif + + --node_id->nid_refcount; + + **root_l=switch_node; + *root_l=&case_node->node_arguments->arg_node; + + return switch_node; +} + +static NodeP new_case_node (SymbolP symbol,int symbol_arity,NodeP node,NodeDefP **def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,StrictNodeIdP **strict_node_ids_l +#endif + ) +{ + NodeP case_node; + + case_node=CompAllocType (NodeS); + + case_node->node_kind=CaseNode; + case_node->node_symbol=symbol; + case_node->node_arity=symbol_arity; + case_node->node_arguments=NewArgument (node); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_node->node_su.su_u.u_case=CompAllocType (CaseNodeContentsS); + case_node->node_strict_node_ids=NULL; +#endif + + case_node->node_node_id_ref_counts=NULL; + + case_node->node_node_defs=**def_l; + **def_l=NULL; + *def_l=&case_node->node_node_defs; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + case_node->node_strict_node_ids=**strict_node_ids_l; + **strict_node_ids_l=NULL; + *strict_node_ids_l=&case_node->node_strict_node_ids; +#endif + + return case_node; +} + +struct root_and_defs_l { + NodeP ** root_l; + NodeDefP ** def_l; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP **strict_node_ids_l; + NodeDefP ** end_lhs_defs_l; +#endif +}; + +struct root_and_defs { + NodeP root; + NodeDefP defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP strict_node_ids; +#endif +}; + +static NodeP new_push_node (Symbol symbol,int arity,ArgP arguments) +{ + NodeP push_node; + + push_node=CompAllocType (NodeS); + + push_node->node_kind=PushNode; + push_node->node_arity=arity; + push_node->node_arguments=arguments; + push_node->node_record_symbol=symbol; + push_node->node_number=0; /* if !=0 then unique */ + + return push_node; +} + +NodeIdRefCountListP new_node_id_ref_count (NodeIdRefCountListP node_id_ref_count_list,NodeIdP node_id,int ref_count) +{ + NodeIdRefCountListP new_node_id_ref_count_elem; + + new_node_id_ref_count_elem=CompAllocType (NodeIdRefCountListS); + + new_node_id_ref_count_elem->nrcl_next=node_id_ref_count_list; + new_node_id_ref_count_elem->nrcl_node_id=node_id; + new_node_id_ref_count_elem->nrcl_ref_count=ref_count; + + return new_node_id_ref_count_elem; +} + +static NodeIdRefCountListP *insert_new_node_id_ref_count (NodeIdRefCountListP *node_id_ref_count_p,NodeIdP node_id,int ref_count) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id,ref_count); + *node_id_ref_count_p=node_id_ref_count_elem; + + return &node_id_ref_count_elem->nrcl_next; +} + +static void transform_normal_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp); + +static void transform_pattern_arguments (SymbolP symbol,ArgP arguments,int arity,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP push_node; + NodeIdListElementP *last_node_id_p; + ArgP arg,arg1,arg2; + + arg2=NewArgument (**root_and_defs_lp->root_l); + arg1=NewArgument (NULL); + arg1->arg_next=arg2; + + push_node=new_push_node (symbol,arity,arg1); + + **root_and_defs_lp->root_l=push_node; + *root_and_defs_lp->root_l=&arg2->arg_node; + + last_node_id_p=&push_node->node_node_ids; + + for_l (arg,arguments,arg_next){ + NodeIdP argument_node_id; + NodeP node; + + node=arg->arg_node; + if (node->node_kind==NormalNode){ + argument_node_id=NewNodeId (NULL); + argument_node_id->nid_refcount=-1; + + argument_node_id->nid_lhs_state_p_=&arg->arg_state; + + transform_normal_pattern_node (node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } else { +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + NodeP argument_node_id_node; + + argument_node_id=node->node_node_id; + + argument_node_id->nid_lhs_state_p_=&arg->arg_state; + + argument_node_id_node=argument_node_id->nid_node; + if (argument_node_id_node){ + argument_node_id->nid_node=NULL; + transform_normal_pattern_node (argument_node_id_node,&arg->arg_state,argument_node_id,root_and_defs_lp); + } +#else + argument_node_id=node->node_node_id; + if (argument_node_id->nid_node) + transform_normal_pattern_node (argument_node_id->nid_node,&arg->arg_state,argument_node_id,root_and_defs_lp); +#endif + } + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + argument_node_id->nid_state_=arg->arg_state; +#endif + + *last_node_id_p=CompAllocType (NodeIdListElementS); + (*last_node_id_p)->nidl_node_id=argument_node_id; + last_node_id_p=&(*last_node_id_p)->nidl_next; + } + + *last_node_id_p=NULL; + + arg1->arg_node=NewNodeIdNode (node_id); +} + +static void transform_normal_pattern_node (NodeP node,StateP state_p,NodeIdP node_id,struct root_and_defs_l *root_and_defs_lp) +{ + SymbolP symbol; + NodeP switch_node,case_node; + NodeP **root_l; + NodeDefP **def_l; + + symbol=node->node_symbol; + root_l=root_and_defs_lp->root_l; + def_l=root_and_defs_lp->def_l; + + switch (symbol->symb_kind){ + case definition: + case_node=new_case_node (symbol,node->node_arity,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + + if (node->node_arity>0) + transform_pattern_arguments (symbol,node->node_arguments,node->node_arity,node_id,root_and_defs_lp); + + return; + case cons_symb: + case_node=new_case_node (symbol,2,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + transform_pattern_arguments (symbol,node->node_arguments,2,node_id,root_and_defs_lp); + return; + case nil_symb: + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + case tuple_symb: + case_node=new_case_node (symbol,node->node_arity,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + transform_pattern_arguments (symbol,node->node_arguments,node->node_arity,node_id,root_and_defs_lp); + return; + case apply_symb: + case if_symb: + error_in_function ("transform_normal_pattern_node"); + return; + case string_denot: + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + default: + if (symbol->symb_kind < Nr_Of_Basic_Types) + error_in_function ("transform_normal_pattern_node"); + else { +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (state_p->state_object==BasicSymbolStates [symbol->symb_kind].state_object){ +#endif + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + } else if (state_p->state_object==UnknownObj +# if ABSTRACT_OBJECT + || state_p->state_object==AbstractObj +# endif + ){ + case_node=new_case_node (symbol,0,**root_l,def_l +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + ,root_and_defs_lp->strict_node_ids_l +#endif + ); + switch_node=new_switch_node (node_id,case_node,state_p,root_l); + return; + } else + error_in_function ("transform_normal_pattern_node"); +#endif + } + } +} + +static void transform_argument (ArgP arg_p,struct root_and_defs_l *root_and_defs_lp) +{ + NodeP node; + + node=arg_p->arg_node; + + switch (node->node_kind){ + case NormalNode: +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + ArgP arg; + + for_l (arg,node->node_arguments,arg_next) + transform_argument (arg,root_and_defs_lp); + } else +#endif + { + NodeIdP node_id; + + node_id=NewNodeId (NULL); + node_id->nid_refcount=-1; + + node_id->nid_lhs_state_p_=&arg_p->arg_state; + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + if (node->node_symbol->symb_kind==tuple_symb || + (node->node_symbol->symb_kind==definition && node->node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { + error_in_function ("transform_argument"); + } else +#endif + transform_normal_pattern_node (node,&arg_p->arg_state,node_id,root_and_defs_lp); + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_state_=arg_p->arg_state; +#endif + arg_p->arg_node=NewNodeIdNode (node_id); + } + break; + case NodeIdNode: + { + NodeIdP node_id; + + node_id=node->node_node_id; + + if (node_id->nid_node!=NULL){ +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + SymbolP node_id_nid_node_symbol; + + node_id_nid_node_symbol=node_id->nid_node->node_symbol; + if (node_id_nid_node_symbol->symb_kind==tuple_symb || + (node_id_nid_node_symbol->symb_kind==definition && node_id_nid_node_symbol->symb_def->sdef_kind==RECORDTYPE)) + { + error_in_function ("transform_argument 1"); + } +#else + if (arg_p->arg_state.state_type==TupleState || arg_p->arg_state.state_type==RecordState){ + error_in_function ("transform_argument 1"); + } else +#endif + { + transform_normal_pattern_node (node_id->nid_node,&arg_p->arg_state,node_id,root_and_defs_lp); + + node_id->nid_node=NULL; + } + } + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + node_id->nid_lhs_state_p_=&arg_p->arg_state; +#else + node_id->nid_state_=arg_p->arg_state; +#endif + break; + } + default: + error_in_function ("transform_argument"); + } +} + +#if 0 +# include "dbprint.h" +#endif + +static void replace_global_ref_count_by_local_ref_count (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ + int local_ref_count; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + local_ref_count=node_id_ref_count_elem->nrcl_ref_count; + +#if DEBUG_OUTPUT + printf ("global_to_local %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + node_id_ref_count_elem->nrcl_ref_count=node_id->nid_refcount - local_ref_count; + node_id->nid_refcount = local_ref_count; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif +} + +void set_local_reference_counts (NodeP case_node) +{ + replace_global_ref_count_by_local_ref_count (case_node->node_node_id_ref_counts); +} + +static void replace_local_ref_count_by_global_ref_count (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem; + + for_l (node_id_ref_count_elem,node_id_ref_count_list,nrcl_next){ + int local_ref_count; + NodeIdP node_id; + + node_id=node_id_ref_count_elem->nrcl_node_id; + local_ref_count=node_id->nid_refcount; + +#if DEBUG_OUTPUT + printf ("local_to_global %s %d %d ",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + node_id->nid_refcount = local_ref_count + node_id_ref_count_elem->nrcl_ref_count; + node_id_ref_count_elem->nrcl_ref_count=local_ref_count; + } + +#if DEBUG_OUTPUT + printf ("\n"); +#endif +} + +void set_global_reference_counts (NodeP case_node) +{ + replace_local_ref_count_by_global_ref_count (case_node->node_node_id_ref_counts); +} + +static void merge_node_id_ref_count_lists (NodeIdRefCountListP *list1_p,NodeIdRefCountListP list2) +{ + while (list2!=NULL){ + NodeIdP node_id; + NodeIdRefCountListP next_list2,list1; + + node_id=list2->nrcl_node_id; + + while (list1=*list1_p,list1!=NULL && list1->nrcl_node_id<=node_id) + list1_p=&list1->nrcl_next; + + if (list1==NULL){ + *list1_p=list2; + return; + } + + next_list2=list2->nrcl_next; + + *list1_p=list2; + list2->nrcl_next=list1; + list1_p=&list2->nrcl_next; + + list2=next_list2; + } +} + +static void sort_node_id_ref_count_lists (NodeIdRefCountListP *list_p) +{ + NodeIdRefCountListP element1,element2,element3; + + element1=*list_p; + if (element1==NULL) + return; + + element2=element1->nrcl_next; + if (element2==NULL) + return; + + element3=element2->nrcl_next; + if (element3==NULL){ + if (element1->nrcl_node_id<=element2->nrcl_node_id) + return; + + *list_p=element2; + element2->nrcl_next=element1; + element1->nrcl_next=NULL; + } else { + NodeIdRefCountListP list2,end_list1,end_list2; + + list2=element2; + end_list1=element1; + end_list2=element2; + + element1=element3; + do { + end_list1->nrcl_next=element1; + end_list1=element1; + + element2=element1->nrcl_next; + if (element2==NULL) + break; + + end_list2->nrcl_next=element2; + end_list2=element2; + + element1=element2->nrcl_next; + } while (element1!=NULL); + + end_list1->nrcl_next=NULL; + end_list2->nrcl_next=NULL; + + sort_node_id_ref_count_lists (list_p); + sort_node_id_ref_count_lists (&list2); + + merge_node_id_ref_count_lists (list_p,list2); + } +} + +static void add_sorted_node_id_ref_count_list (NodeIdRefCountListP *node_id_ref_count_list1_p,NodeIdRefCountListP node_id_ref_count_list2) +{ + NodeIdRefCountListP node_id_ref_count_list1; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1=*node_id_ref_count_list1_p,node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id) + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + +#if DEBUG_OUTPUT + printf ("add %s %d %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count,node_id_ref_count_list2->nrcl_ref_count); +#endif + + node_id_ref_count_list1->nrcl_ref_count += node_id_ref_count_list2->nrcl_ref_count+1; + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + } else { + NodeIdRefCountListP new_node_id_ref_count_elem; + +#if DEBUG_OUTPUT + printf ("addnew %s %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); +#endif + + new_node_id_ref_count_elem=new_node_id_ref_count (node_id_ref_count_list1,node_id_ref_count_list2->nrcl_node_id,node_id_ref_count_list2->nrcl_ref_count); + + *node_id_ref_count_list1_p=new_node_id_ref_count_elem; + node_id_ref_count_list1_p=&new_node_id_ref_count_elem->nrcl_next; + } + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } +} + +/* JVG added 16-2-2000 */ +static void add_sorted_node_id_ref_count_list_for_case (NodeIdRefCountListP *node_id_ref_count_list1_p,NodeIdRefCountListP node_id_ref_count_list2) +{ + NodeIdRefCountListP node_id_ref_count_list1; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1=*node_id_ref_count_list1_p,node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id) + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + +#if DEBUG_OUTPUT + printf ("add %s %d %d %d\n",node_id_name (node_id),node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count,node_id_ref_count_list2->nrcl_ref_count); +#endif + + node_id_ref_count_list1->nrcl_ref_count += node_id_ref_count_list2->nrcl_ref_count+1; + node_id_ref_count_list1_p=&node_id_ref_count_list1->nrcl_next; + } /* else do nothing*/ + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } +} +/**/ + +/* + static NodeIdRefCountListP merge_sorted_node_id_ref_count_lists + (NodeIdRefCountListP node_id_ref_count_list1,NodeIdRefCountListP node_id_ref_count_list2) + { + NodeIdRefCountListP node_id_ref_count_list,*node_id_ref_count_list_p; + + node_id_ref_count_list_p=&node_id_ref_count_list; + + while (node_id_ref_count_list2!=NULL){ + NodeIdP node_id; + + node_id=node_id_ref_count_list2->nrcl_node_id; + + while (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id<node_id){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list1->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name; + + printf ("from1 %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list1->nrcl_node_id,node_id_ref_count_list1->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } + + if (node_id_ref_count_list1!=NULL && node_id_ref_count_list1->nrcl_node_id==node_id){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id->nid_ident!=NULL && node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id->nid_ident->ident_name; + + printf ("combine %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id, + node_id_ref_count_list1->nrcl_ref_count+node_id_ref_count_list2->nrcl_ref_count+1); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } else { + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list2->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list2->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list2->nrcl_node_id->nid_ident->ident_name; + + printf ("from2 %s %d %d\n",node_id_name,node_id_ref_count_list2->nrcl_node_id->nid_refcount,node_id_ref_count_list2->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list2->nrcl_node_id,node_id_ref_count_list2->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + } + + node_id_ref_count_list2=node_id_ref_count_list2->nrcl_next; + } + + while (node_id_ref_count_list1!=NULL){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + #if DEBUG_OUTPUT + { + char *node_id_name; + + node_id_name=""; + if (node_id_ref_count_list1->nrcl_node_id->nid_ident!=NULL && node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name!=NULL) + node_id_name=node_id_ref_count_list1->nrcl_node_id->nid_ident->ident_name; + + printf ("from1 %s %d %d\n",node_id_name,node_id_ref_count_list1->nrcl_node_id->nid_refcount,node_id_ref_count_list1->nrcl_ref_count); + } + #endif + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_list1->nrcl_node_id,node_id_ref_count_list1->nrcl_ref_count); + + *node_id_ref_count_list_p=new_node_id_ref_count_elem; + node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + + node_id_ref_count_list1=node_id_ref_count_list1->nrcl_next; + } + + *node_id_ref_count_list_p=NULL; + + return node_id_ref_count_list; + } +*/ + +static NodeIdRefCountListP duplicate_node_id_ref_count_list (NodeIdRefCountListP node_id_ref_count_list) +{ + NodeIdRefCountListP node_id_ref_count_elem,new_node_id_ref_count_list,*new_node_id_ref_count_list_p; + + new_node_id_ref_count_list_p=&new_node_id_ref_count_list; + + for (node_id_ref_count_elem=node_id_ref_count_list; node_id_ref_count_elem!=NULL; node_id_ref_count_elem=node_id_ref_count_elem->nrcl_next){ + NodeIdRefCountListP new_node_id_ref_count_elem; + + new_node_id_ref_count_elem=new_node_id_ref_count (NULL,node_id_ref_count_elem->nrcl_node_id,node_id_ref_count_elem->nrcl_ref_count); + +#if DEBUG_OUTPUT + printf ("duplicate %s %d %d\n",node_id_name (node_id_ref_count_elem->nrcl_node_id),node_id_ref_count_elem->nrcl_node_id->nid_refcount,node_id_ref_count_elem->nrcl_ref_count); +#endif + + *new_node_id_ref_count_list_p=new_node_id_ref_count_elem; + new_node_id_ref_count_list_p=&new_node_id_ref_count_elem->nrcl_next; + } + + *new_node_id_ref_count_list_p=NULL; + + return new_node_id_ref_count_list; +} + +#ifdef CLEAN2 +extern int contains_fail (NodeP node_p); +#endif + +static int determine_failing_cases_and_adjust_ref_counts (NodeP node,NodeIdRefCountListP *node_id_ref_count_list_p) +{ + switch (node->node_kind){ + case SwitchNode: + { + ArgP arg; + int switch_may_fail,default_may_fail; + int node_id_ref_count_list_sorted; + + node_id_ref_count_list_sorted=0; + + for (arg=node->node_arguments; arg!=NULL; arg=arg->arg_next) + if (arg->arg_node->node_kind!=CaseNode) + break; + + default_may_fail=1; + + if (arg!=NULL){ + NodeP arg_node; + + arg_node=arg->arg_node; + + if (arg_node->node_kind!=DefaultNode) + error_in_function ("determine_failing_cases_and_adjust_ref_counts"); + + default_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + arg_node->node_number=default_may_fail; + + if (default_may_fail){ + /* NodeP default_rhs_node; */ + + sort_node_id_ref_count_lists (&arg_node->node_node_id_ref_counts); + + if (!node_id_ref_count_list_sorted){ + sort_node_id_ref_count_lists (node_id_ref_count_list_p); + node_id_ref_count_list_sorted=1; + } + + /* JVG: maybe incorrect, optimisation: find simple case which can not fail and set node_id_refcounts + default_rhs_node=arg_node->node_arguments->arg_node; + + if (default_rhs_node->node_kind==PushNode) + default_rhs_node=default_rhs_node->node_arguments->arg_next->arg_node; + + if (default_rhs_node->node_kind==SwitchNode && default_rhs_node->node_arguments->arg_next==NULL) + default_rhs_node->node_arguments->arg_node->node_node_id_ref_counts + = duplicate_node_id_ref_count_list (arg_node->node_node_id_ref_counts); + */ + + add_sorted_node_id_ref_count_list (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + + /* + arg_node->node_node_id_ref_counts=merge_sorted_node_id_ref_count_lists (arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + */ + } else + node_id_ref_count_list_p=&arg_node->node_node_id_ref_counts; + } + + switch_may_fail=1; + + /* to do: if non failing case for every constructor, default not reachable */ + +#if 1 /* added 8-4-1999 */ + if (node->node_arguments->arg_next==NULL && node->node_arguments->arg_node->node_kind==CaseNode + && (node->node_arguments->arg_node->node_symbol->symb_kind==tuple_symb + || (node->node_arguments->arg_node->node_symbol->symb_kind==definition && + node->node_arguments->arg_node->node_symbol->symb_def->sdef_kind==RECORDTYPE))) + { + int case_may_fail; + NodeP arg_node; + + arg_node=node->node_arguments->arg_node; + + case_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + + arg_node->node_number=case_may_fail; + + switch_may_fail=case_may_fail; + } else +#endif + + for_l (arg,node->node_arguments,arg_next){ + NodeP arg_node; + + arg_node=arg->arg_node; + + switch (arg_node->node_kind){ + case CaseNode: + { + int case_may_fail; + + case_may_fail=determine_failing_cases_and_adjust_ref_counts (arg_node->node_arguments->arg_node,node_id_ref_count_list_p); + + if (case_may_fail && node->node_arguments->arg_next!=NULL){ + /* NodeP case_rhs_node; */ + + sort_node_id_ref_count_lists (&arg_node->node_node_id_ref_counts); + + if (!node_id_ref_count_list_sorted){ + sort_node_id_ref_count_lists (node_id_ref_count_list_p); + node_id_ref_count_list_sorted=1; + } + + /* JVG: maybe incorrect, optimisation: find simple case which can not fail and set node_id_refcounts + case_rhs_node=arg_node->node_arguments->arg_node; + + if (case_rhs_node->node_kind==PushNode) + case_rhs_node=case_rhs_node->node_arguments->arg_next->arg_node; + + if (case_rhs_node->node_kind==SwitchNode && case_rhs_node->node_arguments->arg_next==NULL) + case_rhs_node->node_arguments->arg_node->node_node_id_ref_counts + = duplicate_node_id_ref_count_list (arg_node->node_node_id_ref_counts); + */ + + /* JVG changed 16-2-2000 + add_sorted_node_id_ref_count_list (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + */ + add_sorted_node_id_ref_count_list_for_case (&arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + /**/ + + /* + arg_node->node_node_id_ref_counts= + merge_sorted_node_id_ref_count_lists (arg_node->node_node_id_ref_counts,*node_id_ref_count_list_p); + */ + } + + arg_node->node_number=case_may_fail; + break; + } + case DefaultNode: + switch_may_fail=default_may_fail; + break; + default: + error_in_function ("determine_failing_cases_and_adjust_ref_counts"); + } + } + return switch_may_fail; + } + case PushNode: + return determine_failing_cases_and_adjust_ref_counts (node->node_arguments->arg_next->arg_node,node_id_ref_count_list_p); + case GuardNode: + return determine_failing_cases_and_adjust_ref_counts (node->node_arguments->arg_next->arg_node,node_id_ref_count_list_p); + case IfNode: +#ifdef CLEAN2 + return contains_fail (node); +#else + { + NodeP else_node; + + else_node=node->node_arguments->arg_next->arg_next->arg_node; + while (else_node->node_kind==IfNode) + else_node=else_node->node_arguments->arg_next->arg_next->arg_node; + + return else_node->node_kind==NormalNode && else_node->node_symbol->symb_kind==fail_symb; + } +#endif + default: + return False; + } +} + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS +void determine_failing_cases_and_adjust_ref_counts_of_rule (RuleAltP first_alt) +{ + NodeIdRefCountListP node_id_ref_count_list; + + if (first_alt->alt_kind!=Contractum) + return; + + node_id_ref_count_list=NULL; + determine_failing_cases_and_adjust_ref_counts (first_alt->alt_rhs_root,&node_id_ref_count_list); + +# if 0 + PrintRuleAlt (first_alt,4,StdOut); +# endif +} +#endif + +#if 0 +#include "dbprint.h" +#endif + +void transform_patterns_to_case_and_guard_nodes (RuleAltP rule_alts) +{ + RuleAltP first_alt; + ArgP arg; + struct root_and_defs_l root_and_defs_l; + NodeP *node_p; + NodeDefP *def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + StrictNodeIdP *strict_node_ids_p; + NodeDefP *end_lhs_defs_p; +#endif + + first_alt=rule_alts; + + if (first_alt->alt_kind!=Contractum) + return; + + node_p=&first_alt->alt_rhs_root; + def_p=&first_alt->alt_rhs_defs; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + strict_node_ids_p=&first_alt->alt_strict_node_ids; + end_lhs_defs_p=&first_alt->alt_lhs_defs; +#endif + + root_and_defs_l.root_l=&node_p; + root_and_defs_l.def_l=&def_p; +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + root_and_defs_l.strict_node_ids_l=&strict_node_ids_p; + root_and_defs_l.end_lhs_defs_l=&end_lhs_defs_p; +#endif + + for_l (arg,first_alt->alt_lhs_root->node_arguments,arg_next) + transform_argument (arg,&root_and_defs_l); + + if (first_alt->alt_next!=NULL) + error_in_function ("transform_patterns_to_case_and_guard_nodes"); + +#ifdef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + *end_lhs_defs_p=NULL; +#endif + + first_alt->alt_next=NULL; + +#if 0 + PrintRuleAlt (first_alt,4,StdOut); +#endif + +#ifndef TRANSFORM_PATTERNS_BEFORE_STRICTNESS_ANALYSIS + { + NodeIdRefCountListP node_id_ref_count_list; + + node_id_ref_count_list=NULL; + determine_failing_cases_and_adjust_ref_counts (first_alt->alt_rhs_root,&node_id_ref_count_list); + } + +# if 0 + PrintRuleAlt (first_alt,4,StdOut); +# endif +#endif +} |