ghc/compiler/yaccParser/U_treeHACK.hs

   1
   2
   3 module U_treeHACK where
   4 import UgenUtil
   5 import Util
   6
   7 import U_binding
   8 import U_coresyn        ( U_coresyn )   -- interface only
   9 import U_hpragma        ( U_hpragma )   -- interface only
  10 import U_list
  11 import U_literal
  12 import U_ttype
  13
  14 type U_infixTree = (ProtoName, U_tree, U_tree)
  15
  16 rdU_infixTree :: _Addr -> UgnM U_infixTree
  17 rdU_infixTree pt
  18   = ioToUgnM (_casm_ ``%r = gident(*Rginfun((struct Sap *)%0));'' pt) `thenUgn` \ op_t ->
  19     ioToUgnM (_casm_ ``%r = (*Rginarg1((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t ->
  20     ioToUgnM (_casm_ ``%r = (*Rginarg2((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t ->
  21
  22     rdU_unkId op_t              `thenUgn` \ op   ->
  23     rdU_tree  arg1_t            `thenUgn` \ arg1 ->
  24     rdU_tree  arg2_t            `thenUgn` \ arg2 ->
  25     returnUgn (op, arg1, arg2)
  26
  27 data U_tree = U_hmodule U_stringId U_list U_list U_binding U_long | U_ident U_unkId | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree U_long | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as U_unkId U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop U_infixTree | U_lsection U_tree U_unkId | U_rsection U_unkId U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall U_stringId U_stringId U_list | U_scc U_hstring U_tree | U_negate U_tree
  28
  29 rdU_tree :: _Addr -> UgnM U_tree
  30 rdU_tree t
  31   = ioToUgnM (_ccall_ ttree t) `thenUgn` \ tag@(I# _) ->
  32     if tag == ``hmodule'' then
  33         ioToUgnM (_ccall_ ghname t) `thenUgn` \ x_ghname ->
  34         rdU_stringId x_ghname `thenUgn` \ y_ghname ->
  35         ioToUgnM (_ccall_ ghimplist t) `thenUgn` \ x_ghimplist ->
  36         rdU_list x_ghimplist `thenUgn` \ y_ghimplist ->
  37         ioToUgnM (_ccall_ ghexplist t) `thenUgn` \ x_ghexplist ->
  38         rdU_list x_ghexplist `thenUgn` \ y_ghexplist ->
  39         ioToUgnM (_ccall_ ghmodlist t) `thenUgn` \ x_ghmodlist ->
  40         rdU_binding x_ghmodlist `thenUgn` \ y_ghmodlist ->
  41         ioToUgnM (_ccall_ ghmodline t) `thenUgn` \ x_ghmodline ->
  42         rdU_long x_ghmodline `thenUgn` \ y_ghmodline ->
  43         returnUgn (U_hmodule y_ghname y_ghimplist y_ghexplist y_ghmodlist y_ghmodline)
  44     else if tag == ``ident'' then
  45         ioToUgnM (_ccall_ gident t) `thenUgn` \ x_gident ->
  46         rdU_unkId x_gident `thenUgn` \ y_gident ->
  47         returnUgn (U_ident y_gident)
  48     else if tag == ``lit'' then
  49         ioToUgnM (_ccall_ glit t) `thenUgn` \ x_glit ->
  50         rdU_literal x_glit `thenUgn` \ y_glit ->
  51         returnUgn (U_lit y_glit)
  52     else if tag == ``tuple'' then
  53         ioToUgnM (_ccall_ gtuplelist t) `thenUgn` \ x_gtuplelist ->
  54         rdU_list x_gtuplelist `thenUgn` \ y_gtuplelist ->
  55         returnUgn (U_tuple y_gtuplelist)
  56     else if tag == ``ap'' then
  57         ioToUgnM (_ccall_ gfun t) `thenUgn` \ x_gfun ->
  58         rdU_tree x_gfun `thenUgn` \ y_gfun ->
  59         ioToUgnM (_ccall_ garg t) `thenUgn` \ x_garg ->
  60         rdU_tree x_garg `thenUgn` \ y_garg ->
  61         returnUgn (U_ap y_gfun y_garg)
  62     else if tag == ``lambda'' then
  63         ioToUgnM (_ccall_ glampats t) `thenUgn` \ x_glampats ->
  64         rdU_list x_glampats `thenUgn` \ y_glampats ->
  65         ioToUgnM (_ccall_ glamexpr t) `thenUgn` \ x_glamexpr ->
  66         rdU_tree x_glamexpr `thenUgn` \ y_glamexpr ->
  67         ioToUgnM (_ccall_ glamline t) `thenUgn` \ x_glamline ->
  68         rdU_long x_glamline `thenUgn` \ y_glamline ->
  69         returnUgn (U_lambda y_glampats y_glamexpr y_glamline)
  70     else if tag == ``let'' then
  71         ioToUgnM (_ccall_ gletvdeflist t) `thenUgn` \ x_gletvdeflist ->
  72         rdU_binding x_gletvdeflist `thenUgn` \ y_gletvdeflist ->
  73         ioToUgnM (_ccall_ gletvexpr t) `thenUgn` \ x_gletvexpr ->
  74         rdU_tree x_gletvexpr `thenUgn` \ y_gletvexpr ->
  75         returnUgn (U_let y_gletvdeflist y_gletvexpr)
  76     else if tag == ``casee'' then
  77         ioToUgnM (_ccall_ gcaseexpr t) `thenUgn` \ x_gcaseexpr ->
  78         rdU_tree x_gcaseexpr `thenUgn` \ y_gcaseexpr ->
  79         ioToUgnM (_ccall_ gcasebody t) `thenUgn` \ x_gcasebody ->
  80         rdU_list x_gcasebody `thenUgn` \ y_gcasebody ->
  81         returnUgn (U_casee y_gcaseexpr y_gcasebody)
  82     else if tag == ``ife'' then
  83         ioToUgnM (_ccall_ gifpred t) `thenUgn` \ x_gifpred ->
  84         rdU_tree x_gifpred `thenUgn` \ y_gifpred ->
  85         ioToUgnM (_ccall_ gifthen t) `thenUgn` \ x_gifthen ->
  86         rdU_tree x_gifthen `thenUgn` \ y_gifthen ->
  87         ioToUgnM (_ccall_ gifelse t) `thenUgn` \ x_gifelse ->
  88         rdU_tree x_gifelse `thenUgn` \ y_gifelse ->
  89         returnUgn (U_ife y_gifpred y_gifthen y_gifelse)
  90     else if tag == ``par'' then
  91         ioToUgnM (_ccall_ gpare t) `thenUgn` \ x_gpare ->
  92         rdU_tree x_gpare `thenUgn` \ y_gpare ->
  93         returnUgn (U_par y_gpare)
  94     else if tag == ``as'' then
  95         ioToUgnM (_ccall_ gasid t) `thenUgn` \ x_gasid ->
  96         rdU_unkId x_gasid `thenUgn` \ y_gasid ->
  97         ioToUgnM (_ccall_ gase t) `thenUgn` \ x_gase ->
  98         rdU_tree x_gase `thenUgn` \ y_gase ->
  99         returnUgn (U_as y_gasid y_gase)
 100     else if tag == ``lazyp'' then
 101         ioToUgnM (_ccall_ glazyp t) `thenUgn` \ x_glazyp ->
 102         rdU_tree x_glazyp `thenUgn` \ y_glazyp ->
 103         returnUgn (U_lazyp y_glazyp)
 104     else if tag == ``plusp'' then
 105         ioToUgnM (_ccall_ gplusp t) `thenUgn` \ x_gplusp ->
 106         rdU_tree x_gplusp `thenUgn` \ y_gplusp ->
 107         ioToUgnM (_ccall_ gplusi t) `thenUgn` \ x_gplusi ->
 108         rdU_literal x_gplusi `thenUgn` \ y_gplusi ->
 109         returnUgn (U_plusp y_gplusp y_gplusi)
 110     else if tag == ``wildp'' then
 111         returnUgn (U_wildp )
 112     else if tag == ``restr'' then
 113         ioToUgnM (_ccall_ grestre t) `thenUgn` \ x_grestre ->
 114         rdU_tree x_grestre `thenUgn` \ y_grestre ->
 115         ioToUgnM (_ccall_ grestrt t) `thenUgn` \ x_grestrt ->
 116         rdU_ttype x_grestrt `thenUgn` \ y_grestrt ->
 117         returnUgn (U_restr y_grestre y_grestrt)
 118     else if tag == ``comprh'' then
 119         ioToUgnM (_ccall_ gcexp t) `thenUgn` \ x_gcexp ->
 120         rdU_tree x_gcexp `thenUgn` \ y_gcexp ->
 121         ioToUgnM (_ccall_ gcquals t) `thenUgn` \ x_gcquals ->
 122         rdU_list x_gcquals `thenUgn` \ y_gcquals ->
 123         returnUgn (U_comprh y_gcexp y_gcquals)
 124     else if tag == ``qual'' then
 125         ioToUgnM (_ccall_ gqpat t) `thenUgn` \ x_gqpat ->
 126         rdU_tree x_gqpat `thenUgn` \ y_gqpat ->
 127         ioToUgnM (_ccall_ gqexp t) `thenUgn` \ x_gqexp ->
 128         rdU_tree x_gqexp `thenUgn` \ y_gqexp ->
 129         returnUgn (U_qual y_gqpat y_gqexp)
 130     else if tag == ``guard'' then
 131         ioToUgnM (_ccall_ ggexp t) `thenUgn` \ x_ggexp ->
 132         rdU_tree x_ggexp `thenUgn` \ y_ggexp ->
 133         returnUgn (U_guard y_ggexp)
 134     else if tag == ``def'' then
 135         ioToUgnM (_ccall_ ggdef t) `thenUgn` \ x_ggdef ->
 136         rdU_tree x_ggdef `thenUgn` \ y_ggdef ->
 137         returnUgn (U_def y_ggdef)
 138     else if tag == ``tinfixop'' then
 139 --      ioToUgnM (_ccall_ gdummy t) `thenUgn` \ x_gdummy ->
 140         rdU_infixTree t {-THIS IS THE HACK-} `thenUgn` \ y_gdummy ->
 141         returnUgn (U_tinfixop y_gdummy)
 142     else if tag == ``lsection'' then
 143         ioToUgnM (_ccall_ glsexp t) `thenUgn` \ x_glsexp ->
 144         rdU_tree x_glsexp `thenUgn` \ y_glsexp ->
 145         ioToUgnM (_ccall_ glsop t) `thenUgn` \ x_glsop ->
 146         rdU_unkId x_glsop `thenUgn` \ y_glsop ->
 147         returnUgn (U_lsection y_glsexp y_glsop)
 148     else if tag == ``rsection'' then
 149         ioToUgnM (_ccall_ grsop t) `thenUgn` \ x_grsop ->
 150         rdU_unkId x_grsop `thenUgn` \ y_grsop ->
 151         ioToUgnM (_ccall_ grsexp t) `thenUgn` \ x_grsexp ->
 152         rdU_tree x_grsexp `thenUgn` \ y_grsexp ->
 153         returnUgn (U_rsection y_grsop y_grsexp)
 154     else if tag == ``eenum'' then
 155         ioToUgnM (_ccall_ gefrom t) `thenUgn` \ x_gefrom ->
 156         rdU_tree x_gefrom `thenUgn` \ y_gefrom ->
 157         ioToUgnM (_ccall_ gestep t) `thenUgn` \ x_gestep ->
 158         rdU_list x_gestep `thenUgn` \ y_gestep ->
 159         ioToUgnM (_ccall_ geto t) `thenUgn` \ x_geto ->
 160         rdU_list x_geto `thenUgn` \ y_geto ->
 161         returnUgn (U_eenum y_gefrom y_gestep y_geto)
 162     else if tag == ``llist'' then
 163         ioToUgnM (_ccall_ gllist t) `thenUgn` \ x_gllist ->
 164         rdU_list x_gllist `thenUgn` \ y_gllist ->
 165         returnUgn (U_llist y_gllist)
 166     else if tag == ``ccall'' then
 167         ioToUgnM (_ccall_ gccid t) `thenUgn` \ x_gccid ->
 168         rdU_stringId x_gccid `thenUgn` \ y_gccid ->
 169         ioToUgnM (_ccall_ gccinfo t) `thenUgn` \ x_gccinfo ->
 170         rdU_stringId x_gccinfo `thenUgn` \ y_gccinfo ->
 171         ioToUgnM (_ccall_ gccargs t) `thenUgn` \ x_gccargs ->
 172         rdU_list x_gccargs `thenUgn` \ y_gccargs ->
 173         returnUgn (U_ccall y_gccid y_gccinfo y_gccargs)
 174     else if tag == ``scc'' then
 175         ioToUgnM (_ccall_ gsccid t) `thenUgn` \ x_gsccid ->
 176         rdU_hstring x_gsccid `thenUgn` \ y_gsccid ->
 177         ioToUgnM (_ccall_ gsccexp t) `thenUgn` \ x_gsccexp ->
 178         rdU_tree x_gsccexp `thenUgn` \ y_gsccexp ->
 179         returnUgn (U_scc y_gsccid y_gsccexp)
 180     else if tag == ``negate'' then
 181         ioToUgnM (_ccall_ gnexp t) `thenUgn` \ x_gnexp ->
 182         rdU_tree x_gnexp `thenUgn` \ y_gnexp ->
 183         returnUgn (U_negate y_gnexp)
 184     else
 185         error ("rdU_tree: bad tag selection:"++show tag++"\n")