[project @ 1996-01-08 20:28:12 by partain]

[ghc-hetmet.git] / ghc / compiler / yaccParser / U_hpragma.hs

diff --git a/ghc/compiler/yaccParser/U_hpragma.hs b/ghc/compiler/yaccParser/U_hpragma.hs
new file mode 100644 (file)
index 0000000..97c81bb
--- /dev/null
+++ b/ghc/compiler/yaccParser/U_hpragma.hs
@@ -0,0 +1,139 @@
+
+
+module U_hpragma where
+import UgenUtil
+import Util
+
+import U_coresyn
+import U_list
+import U_literal       ( U_literal )   -- ditto
+import U_ttype         ( U_ttype )     -- interface only
+data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma U_stringId U_hpragma | U_iinst_const_pragma U_stringId U_hpragma U_list | U_iinst_spec_pragma U_stringId U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma U_numId | U_iupdate_pragma U_stringId | U_ideforest_pragma | U_istrictness_pragma U_hstring U_hpragma | U_imagic_unfolding_pragma U_stringId | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args U_numId U_numId U_stringId U_numId | U_iname_pragma_pr U_unkId U_hpragma | U_itype_pragma_pr U_list U_numId U_hpragma | U_iinst_pragma_3s U_list U_numId U_hpragma U_list | U_idata_pragma_4s U_list 
+
+rdU_hpragma :: _Addr -> UgnM U_hpragma
+rdU_hpragma t
+  = ioToUgnM (_ccall_ thpragma t) `thenUgn` \ tag@(I# _) ->
+    if tag == ``no_pragma'' then
+       returnUgn (U_no_pragma )
+    else if tag == ``idata_pragma'' then
+       ioToUgnM (_ccall_ gprag_data_constrs t) `thenUgn` \ x_gprag_data_constrs ->
+       rdU_list x_gprag_data_constrs `thenUgn` \ y_gprag_data_constrs ->
+       ioToUgnM (_ccall_ gprag_data_specs t) `thenUgn` \ x_gprag_data_specs ->
+       rdU_list x_gprag_data_specs `thenUgn` \ y_gprag_data_specs ->
+       returnUgn (U_idata_pragma y_gprag_data_constrs y_gprag_data_specs)
+    else if tag == ``itype_pragma'' then
+       returnUgn (U_itype_pragma )
+    else if tag == ``iclas_pragma'' then
+       ioToUgnM (_ccall_ gprag_clas t) `thenUgn` \ x_gprag_clas ->
+       rdU_list x_gprag_clas `thenUgn` \ y_gprag_clas ->
+       returnUgn (U_iclas_pragma y_gprag_clas)
+    else if tag == ``iclasop_pragma'' then
+       ioToUgnM (_ccall_ gprag_dsel t) `thenUgn` \ x_gprag_dsel ->
+       rdU_hpragma x_gprag_dsel `thenUgn` \ y_gprag_dsel ->
+       ioToUgnM (_ccall_ gprag_defm t) `thenUgn` \ x_gprag_defm ->
+       rdU_hpragma x_gprag_defm `thenUgn` \ y_gprag_defm ->
+       returnUgn (U_iclasop_pragma y_gprag_dsel y_gprag_defm)
+    else if tag == ``iinst_simpl_pragma'' then
+       ioToUgnM (_ccall_ gprag_imod_simpl t) `thenUgn` \ x_gprag_imod_simpl ->
+       rdU_stringId x_gprag_imod_simpl `thenUgn` \ y_gprag_imod_simpl ->
+       ioToUgnM (_ccall_ gprag_dfun_simpl t) `thenUgn` \ x_gprag_dfun_simpl ->
+       rdU_hpragma x_gprag_dfun_simpl `thenUgn` \ y_gprag_dfun_simpl ->
+       returnUgn (U_iinst_simpl_pragma y_gprag_imod_simpl y_gprag_dfun_simpl)
+    else if tag == ``iinst_const_pragma'' then
+       ioToUgnM (_ccall_ gprag_imod_const t) `thenUgn` \ x_gprag_imod_const ->
+       rdU_stringId x_gprag_imod_const `thenUgn` \ y_gprag_imod_const ->
+       ioToUgnM (_ccall_ gprag_dfun_const t) `thenUgn` \ x_gprag_dfun_const ->
+       rdU_hpragma x_gprag_dfun_const `thenUgn` \ y_gprag_dfun_const ->
+       ioToUgnM (_ccall_ gprag_constms t) `thenUgn` \ x_gprag_constms ->
+       rdU_list x_gprag_constms `thenUgn` \ y_gprag_constms ->
+       returnUgn (U_iinst_const_pragma y_gprag_imod_const y_gprag_dfun_const y_gprag_constms)
+    else if tag == ``iinst_spec_pragma'' then
+       ioToUgnM (_ccall_ gprag_imod_spec t) `thenUgn` \ x_gprag_imod_spec ->
+       rdU_stringId x_gprag_imod_spec `thenUgn` \ y_gprag_imod_spec ->
+       ioToUgnM (_ccall_ gprag_dfun_spec t) `thenUgn` \ x_gprag_dfun_spec ->
+       rdU_hpragma x_gprag_dfun_spec `thenUgn` \ y_gprag_dfun_spec ->
+       ioToUgnM (_ccall_ gprag_inst_specs t) `thenUgn` \ x_gprag_inst_specs ->
+       rdU_list x_gprag_inst_specs `thenUgn` \ y_gprag_inst_specs ->
+       returnUgn (U_iinst_spec_pragma y_gprag_imod_spec y_gprag_dfun_spec y_gprag_inst_specs)
+    else if tag == ``igen_pragma'' then
+       ioToUgnM (_ccall_ gprag_arity t) `thenUgn` \ x_gprag_arity ->
+       rdU_hpragma x_gprag_arity `thenUgn` \ y_gprag_arity ->
+       ioToUgnM (_ccall_ gprag_update t) `thenUgn` \ x_gprag_update ->
+       rdU_hpragma x_gprag_update `thenUgn` \ y_gprag_update ->
+       ioToUgnM (_ccall_ gprag_deforest t) `thenUgn` \ x_gprag_deforest ->
+       rdU_hpragma x_gprag_deforest `thenUgn` \ y_gprag_deforest ->
+       ioToUgnM (_ccall_ gprag_strictness t) `thenUgn` \ x_gprag_strictness ->
+       rdU_hpragma x_gprag_strictness `thenUgn` \ y_gprag_strictness ->
+       ioToUgnM (_ccall_ gprag_unfolding t) `thenUgn` \ x_gprag_unfolding ->
+       rdU_hpragma x_gprag_unfolding `thenUgn` \ y_gprag_unfolding ->
+       ioToUgnM (_ccall_ gprag_specs t) `thenUgn` \ x_gprag_specs ->
+       rdU_list x_gprag_specs `thenUgn` \ y_gprag_specs ->
+       returnUgn (U_igen_pragma y_gprag_arity y_gprag_update y_gprag_deforest y_gprag_strictness y_gprag_unfolding y_gprag_specs)
+    else if tag == ``iarity_pragma'' then
+       ioToUgnM (_ccall_ gprag_arity_val t) `thenUgn` \ x_gprag_arity_val ->
+       rdU_numId x_gprag_arity_val `thenUgn` \ y_gprag_arity_val ->
+       returnUgn (U_iarity_pragma y_gprag_arity_val)
+    else if tag == ``iupdate_pragma'' then
+       ioToUgnM (_ccall_ gprag_update_val t) `thenUgn` \ x_gprag_update_val ->
+       rdU_stringId x_gprag_update_val `thenUgn` \ y_gprag_update_val ->
+       returnUgn (U_iupdate_pragma y_gprag_update_val)
+    else if tag == ``ideforest_pragma'' then
+       returnUgn (U_ideforest_pragma )
+    else if tag == ``istrictness_pragma'' then
+       ioToUgnM (_ccall_ gprag_strict_spec t) `thenUgn` \ x_gprag_strict_spec ->
+       rdU_hstring x_gprag_strict_spec `thenUgn` \ y_gprag_strict_spec ->
+       ioToUgnM (_ccall_ gprag_strict_wrkr t) `thenUgn` \ x_gprag_strict_wrkr ->
+       rdU_hpragma x_gprag_strict_wrkr `thenUgn` \ y_gprag_strict_wrkr ->
+       returnUgn (U_istrictness_pragma y_gprag_strict_spec y_gprag_strict_wrkr)
+    else if tag == ``imagic_unfolding_pragma'' then
+       ioToUgnM (_ccall_ gprag_magic_str t) `thenUgn` \ x_gprag_magic_str ->
+       rdU_stringId x_gprag_magic_str `thenUgn` \ y_gprag_magic_str ->
+       returnUgn (U_imagic_unfolding_pragma y_gprag_magic_str)
+    else if tag == ``iunfolding_pragma'' then
+       ioToUgnM (_ccall_ gprag_unfold_guide t) `thenUgn` \ x_gprag_unfold_guide ->
+       rdU_hpragma x_gprag_unfold_guide `thenUgn` \ y_gprag_unfold_guide ->
+       ioToUgnM (_ccall_ gprag_unfold_core t) `thenUgn` \ x_gprag_unfold_core ->
+       rdU_coresyn x_gprag_unfold_core `thenUgn` \ y_gprag_unfold_core ->
+       returnUgn (U_iunfolding_pragma y_gprag_unfold_guide y_gprag_unfold_core)
+    else if tag == ``iunfold_always'' then
+       returnUgn (U_iunfold_always )
+    else if tag == ``iunfold_if_args'' then
+       ioToUgnM (_ccall_ gprag_unfold_if_t_args t) `thenUgn` \ x_gprag_unfold_if_t_args ->
+       rdU_numId x_gprag_unfold_if_t_args `thenUgn` \ y_gprag_unfold_if_t_args ->
+       ioToUgnM (_ccall_ gprag_unfold_if_v_args t) `thenUgn` \ x_gprag_unfold_if_v_args ->
+       rdU_numId x_gprag_unfold_if_v_args `thenUgn` \ y_gprag_unfold_if_v_args ->
+       ioToUgnM (_ccall_ gprag_unfold_if_con_args t) `thenUgn` \ x_gprag_unfold_if_con_args ->
+       rdU_stringId x_gprag_unfold_if_con_args `thenUgn` \ y_gprag_unfold_if_con_args ->
+       ioToUgnM (_ccall_ gprag_unfold_if_size t) `thenUgn` \ x_gprag_unfold_if_size ->
+       rdU_numId x_gprag_unfold_if_size `thenUgn` \ y_gprag_unfold_if_size ->
+       returnUgn (U_iunfold_if_args y_gprag_unfold_if_t_args y_gprag_unfold_if_v_args y_gprag_unfold_if_con_args y_gprag_unfold_if_size)
+    else if tag == ``iname_pragma_pr'' then
+       ioToUgnM (_ccall_ gprag_name_pr1 t) `thenUgn` \ x_gprag_name_pr1 ->
+       rdU_unkId x_gprag_name_pr1 `thenUgn` \ y_gprag_name_pr1 ->
+       ioToUgnM (_ccall_ gprag_name_pr2 t) `thenUgn` \ x_gprag_name_pr2 ->
+       rdU_hpragma x_gprag_name_pr2 `thenUgn` \ y_gprag_name_pr2 ->
+       returnUgn (U_iname_pragma_pr y_gprag_name_pr1 y_gprag_name_pr2)
+    else if tag == ``itype_pragma_pr'' then
+       ioToUgnM (_ccall_ gprag_type_pr1 t) `thenUgn` \ x_gprag_type_pr1 ->
+       rdU_list x_gprag_type_pr1 `thenUgn` \ y_gprag_type_pr1 ->
+       ioToUgnM (_ccall_ gprag_type_pr2 t) `thenUgn` \ x_gprag_type_pr2 ->
+       rdU_numId x_gprag_type_pr2 `thenUgn` \ y_gprag_type_pr2 ->
+       ioToUgnM (_ccall_ gprag_type_pr3 t) `thenUgn` \ x_gprag_type_pr3 ->
+       rdU_hpragma x_gprag_type_pr3 `thenUgn` \ y_gprag_type_pr3 ->
+       returnUgn (U_itype_pragma_pr y_gprag_type_pr1 y_gprag_type_pr2 y_gprag_type_pr3)
+    else if tag == ``iinst_pragma_3s'' then
+       ioToUgnM (_ccall_ gprag_inst_pt1 t) `thenUgn` \ x_gprag_inst_pt1 ->
+       rdU_list x_gprag_inst_pt1 `thenUgn` \ y_gprag_inst_pt1 ->
+       ioToUgnM (_ccall_ gprag_inst_pt2 t) `thenUgn` \ x_gprag_inst_pt2 ->
+       rdU_numId x_gprag_inst_pt2 `thenUgn` \ y_gprag_inst_pt2 ->
+       ioToUgnM (_ccall_ gprag_inst_pt3 t) `thenUgn` \ x_gprag_inst_pt3 ->
+       rdU_hpragma x_gprag_inst_pt3 `thenUgn` \ y_gprag_inst_pt3 ->
+       ioToUgnM (_ccall_ gprag_inst_pt4 t) `thenUgn` \ x_gprag_inst_pt4 ->
+       rdU_list x_gprag_inst_pt4 `thenUgn` \ y_gprag_inst_pt4 ->
+       returnUgn (U_iinst_pragma_3s y_gprag_inst_pt1 y_gprag_inst_pt2 y_gprag_inst_pt3 y_gprag_inst_pt4)
+    else if tag == ``idata_pragma_4s'' then
+       ioToUgnM (_ccall_ gprag_data_spec t) `thenUgn` \ x_gprag_data_spec ->
+       rdU_list x_gprag_data_spec `thenUgn` \ y_gprag_data_spec ->
+       returnUgn (U_idata_pragma_4s y_gprag_data_spec)
+    else
+       error ("rdU_hpragma: bad tag selection:"++show tag++"\n")