2014-01-31 Basile Starynkevitch <basile@starynkevitch.net>

	{{unstable, since should be boostrapped with make upgrade-warmelt}}
	* melt-predef.list (HOOK_PROCESS_PRAGMA): New.

	* melt/warmelt-first.melt (class_gcc_pragma): New field
	gccpragma_data.
	* melt/warmelt-hooks.melt: Most of pragma support is tree specific
	so goes into xtramelt-ana-tree.melt...
	(pragma_lex, c_register_pragma_with_expansion_and_data)
	(c_register_pragma_with_data, melt_register_pragmas_callback):
	Remove cheader defining them.
	(pragma_processor): New variable.
	(register_pragma_processor): New function.
	(hook_register_pragmas): Improve.
	(check_c_frontend): Move to xtramelt-ana-tree.melt.
	(pragma_handler_tuple): New variable.
	(hook_process_pragma): New hook.
	(cpp_ttype_tuple, register_cpp_ttype, ensure_cpp_ttype_tuple)
	(register_expanded_pragma): Move to xtramelt-ana-tree.melt.
	(add_pragma_handler): New handler.

	* melt/xtramelt-ana-tree.melt: Move most of pragma support from
	warmelt-hooks.melt to here.
	(pragma_lex, c_register_pragma_with_expansion_and_data)
	(c_register_pragma_with_data)
	(melt_register_pragmas_callback, melt_pragma_process_callback):
	Add cheader defining them.
	(check_c_frontend, cpp_ttype_tuple, register_cpp_ttype)
	(ensure_cpp_ttype_tuple, pragma_lex): Function & variable & hook
	moved from warmelt-hooks.melt
	(register_expanded_pragma, register_plain_pragma)
	(real_pragma_processor): New functions.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@207369 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 411 insertions, 109 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index a430474c9cf..3a2a2619df9 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,5 +1,39 @@
 
 
+2014-01-31  Basile Starynkevitch  <basile@starynkevitch.net>
+
+	{{unstable, since should be boostrapped with make upgrade-warmelt}}
+	* melt-predef.list (HOOK_PROCESS_PRAGMA): New.
+
+	* melt/warmelt-first.melt (class_gcc_pragma): New field
+	gccpragma_data.
+	* melt/warmelt-hooks.melt: Most of pragma support is tree specific
+	so goes into xtramelt-ana-tree.melt...
+	(pragma_lex, c_register_pragma_with_expansion_and_data)
+	(c_register_pragma_with_data, melt_register_pragmas_callback):
+	Remove cheader defining them.
+	(pragma_processor): New variable.
+	(register_pragma_processor): New function.
+	(hook_register_pragmas): Improve.
+	(check_c_frontend): Move to xtramelt-ana-tree.melt.
+	(pragma_handler_tuple): New variable.
+	(hook_process_pragma): New hook.
+	(cpp_ttype_tuple, register_cpp_ttype, ensure_cpp_ttype_tuple)
+	(register_expanded_pragma): Move to xtramelt-ana-tree.melt.
+	(add_pragma_handler): New handler.
+
+	* melt/xtramelt-ana-tree.melt: Move most of pragma support from
+	warmelt-hooks.melt to here.
+	(pragma_lex, c_register_pragma_with_expansion_and_data)
+	(c_register_pragma_with_data)
+	(melt_register_pragmas_callback, melt_pragma_process_callback):
+	Add cheader defining them.
+	(check_c_frontend, cpp_ttype_tuple, register_cpp_ttype)
+	(ensure_cpp_ttype_tuple, pragma_lex): Function & variable & hook
+	moved from warmelt-hooks.melt
+	(register_expanded_pragma, register_plain_pragma)
+	(real_pragma_processor): New functions.
+
 2014-01-30  Basile Starynkevitch  <basile@starynkevitch.net>
 
 	* melt/warmelt-hooks.melt (cpp_ttype_tuple): New variable.
diff --git a/gcc/melt-predef.list b/gcc/melt-predef.list
index a4a5cfa0ffc..bd147d1a420 100644
--- a/gcc/melt-predef.list
+++ b/gcc/melt-predef.list
@@ -164,6 +164,7 @@
   HOOK_PATMACRO_EXPORTER
   HOOK_POLL_INPUTS
   HOOK_PRE_GENERICIZE
+  HOOK_PROCESS_PRAGMA
   HOOK_REGISTER_PRAGMAS
   HOOK_RTL_EXECUTE
   HOOK_RTL_GATE
diff --git a/gcc/melt/warmelt-first.melt b/gcc/melt/warmelt-first.melt
index a3a5fb00149..349d6e71195 100644
--- a/gcc/melt/warmelt-first.melt
+++ b/gcc/melt/warmelt-first.melt
@@ -713,6 +713,7 @@ variables for the result is $LABIND_RES.}# )
   :super class_named
   ;; keep the fields list in sync with melt-runtime.h FGCCPRAGMA_*
   :fields (gccpragma_handler            ;the closure to handle the pragma
+	   gccpragma_space
            gccpragma_data               ;extra data
            )
   :doc #{The $CLASS_GCC_PRAGMA is for objects describing GCC pragmas,
diff --git a/gcc/melt/warmelt-hooks.melt b/gcc/melt/warmelt-hooks.melt
index 2c878bf2fdb..140a02460aa 100644
--- a/gcc/melt/warmelt-hooks.melt
+++ b/gcc/melt/warmelt-hooks.melt
@@ -2265,128 +2265,98 @@ exit, in last place.}#
   )
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;           P R A G M A S
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; pragma support is related to trees, so most of it is done in
+;; xtramelt-ana-tree.melt however, the hook is predefined so should
+;; appear here. In fact, it calls a forward reference variable.
 
-(cheader
- #{ /* cheader for pragmas in warmelt-hooks.melt */
- #include "cpplib.h"
-/*** 
-     We declare weak functions because they cannot be linked when we
-     use lto (it loses langage specific informations).  If you use one
-     of those functions you must check them to be not NULL.
-***/
-// Function pragma_lex is declared in c-family/c-pragma.h
-extern enum cpp_ttype pragma_lex (tree *) MELT_WEAK_ON_HOST;
-
-// Function c_register_pragma_with_expansion_and_data from c-family/c-pragma.h
-extern void
-c_register_pragma_with_expansion_and_data (const char *space,
-					   const char *name,
-					   pragma_handler_2arg handler,
-					   void *data) MELT_WEAK_ON_HOST;
-// Function c_register_pragma_with_data from c-family/c-pragma.h
-extern void
-c_register_pragma_with_data (const char *space, const char *name,
-			     pragma_handler_2arg handler,
-			     void *data) MELT_WEAK_ON_HOST;
-
- static void
- melt_register_pragmas_callback (void* gccdata ATTRIBUTE_UNUSED,
-			        void* userdata ATTRIBUTE_UNUSED)
- {
-   melthookproc_HOOK_REGISTER_PRAGMAS ();
- } /* end of melt_register_pragmas_callback */
- }#)
 
-(defhook hook_register_pragmas () () :void
-  :predef HOOK_REGISTER_PRAGMAS
-  (debug "hook_register_pragmas start")
+(defvar pragma_processor)
+
+(defun register_pragma_processor (pfun)
+  (debug "register_pragma_processor pfun=" pfun " pragma_processor=" pragma_processor)
+  (assert_msg "check no pragma_processor" (null pragma_processor) pragma_processor)
+  (if (is_closure pfun)
+      (setq pragma_processor pfun))
   )
 
-(defun check_c_frontend (nam :cstring msg)
-  :doc #{utility function to check that we are indeed within a C or
-  C++ compiler, outside of @tt{lto1} but inside @tt{cc1} or
-  @tt{cc1plus}.}#
-  (assert_msg "check nam" (is_a nam class_named))
-  (let ( (:long good 0)
-	 )
-    (code_chunk
-     checkc_havepragmas_chk
-     #{ /* start check_c_frontend $CHECKC_HAVEPRAGMAS_CHK */
-#ifdef MELT_WEAK_ON_HOST
-     $GOOD = pragma_lex
-           && c_register_pragma_with_expansion_and_data
-           && c_register_pragma_with_data;
-#else
-#error check_c_frontend need MELT_WEAK_ON_HOST
-#endif
-     /* end check_c_frontend $CHECKC_HAVEPRAGMAS_CHK */
-     }#)
-    (debug "check_c_frontend good=" good " nam=" nam " msg=" msg)
-    (unless good
-      (error_at () "Can't use $1 ($2) outside of a C [cc1] or C++ [cc1plus] compiler -e.g. inside [lto1]"
-		nam msg)
-      (let ( (namstr (get_field :named_name nam))
-	     )
-	(assert_msg "check namstr" (is_string namstr) namstr nam)
-	(code_chunk
-	 checkc_fatalerror_chk
-	 #{ /* check_c_frontend $CHECKC_FATALERROR_CHK */
-	 melt_fatal_error("C or C++ frontend expected in %s (%s)",
-			  melt_string_str($NAMSTR),
-			  $MSG);
-	 }#)))
-    ))
+(defvar pragma_handler_tuple)
 
+(defhook hook_process_pragma (:long lix) () :void
+  :predef HOOK_PROCESS_PRAGMA
+  :doc #{$HOOK_PROCESS_PRAGMA is an internal hook to process a pragma.}#
+  (let ( (ph (multiple_nth pragma_handler_tuple lix))
+	 )
+    (debug "hook_process_pragma lix=" lix " ph=" ph)
+    (assert_msg "check ph" (is_a ph class_gcc_pragma))
+    ((get_field :gccpragma_handler ph) ph)
+    (debug "hook_process_pragma done ph=" ph)))
 
-;; a variable to hold lazily the tuple of symbols for 
-(defvar cpp_ttype_tuple)
 
-(defhook register_cpp_ttype (:long ix :cstring name) () :void
-  (assert_msg "check cpp_ttype_tuple" (is_multiple cpp_ttype_tuple) cpp_ttype_tuple)
-  (multiple_put_nth cpp_ttype_tuple ix
-		    (hook_named_symbol
-		     name
-		     (expr_chunk chk_meltcreate :long
-				 #{/*register_cpp_ttype*/ (long)MELT_CREATE}#)))
+;; we define the hook_register_pragmas here so that it gets built by 'make upgrade-warmelt'
+(defhook hook_register_pragmas () () :void
+  :predef HOOK_REGISTER_PRAGMAS
+  (debug "hook_register_pragmas start pragma_processor=" pragma_processor
+	 "pragma_handler_tuple=" pragma_handler_tuple)
+  (if (is_closure pragma_processor)
+      (pragma_processor pragma_handler_tuple))
   )
 
-(defun ensure_cpp_ttype_tuple ()
-  (if cpp_ttype_tuple (return))
-  (let ( (:long nbttype (expr_chunk chk_nbttype :long
-				    #{/*ensure_cpp_ttype_tuple*/ (long) N_TTYPES}#))
-	 (newcpptytuple (make_multiple discr_multiple nbttype))
+(defun add_pragma_handler (ph)
+  :doc #{Internal utility to add a pragma handler $PH which should be
+  a $CLASS_GCC_PRAGMA. See also $REGISTER_EXPANDED_PRAGMA and
+  $REGISTER_PLAIN_PRAGMA from @file{xtramelt-ana-tree.melt}.}#
+  (debug "add_pragma_handler start ph=" ph
+	 " pragma_handler_tuple=" pragma_handler_tuple)
+  (assert_msg "check ph" (is_a ph class_gcc_pragma))
+  (if (null pragma_handler_tuple)
+      (setq pragma_handler_tuple (make_multiple discr_multiple 16)))  
+  (let ( (:long lix 0)
+	 (:long nbph (multiple_length pragma_handler_tuple))
 	 )
-    (setq cpp_ttype_tuple newcpptytuple)
-    (code_chunk
-     cpptypetuple_chk
-     #{ /* ensure_cpp_ttype_tuple $CPPTYPETUPLE_CHK */
-#define MELT_DO_REGISTER_CPP_TTYPE(CppNam) \
-   melthook_REGISTER_CPP_TTYPE($REGISTER_CPP_TTYPE, \
-			       CppNam, #CppNam);
-// macros used by TTYPE_TABLE from cpplib.h
-#ifndef TTYPE_TABLE
-#error TTYPE_TABLE not defined but expected
-#endif
-#define OP(Nam,Str) /*oper*/  MELT_DO_REGISTER_CPP_TTYPE(CPP_##Nam)
-#define TK(Nam,Typ) /*token*/ MELT_DO_REGISTER_CPP_TTYPE(CPP_##Nam)
-// the TTYPE_TABLE below is a long macro
-     TTYPE_TABLE
-#undef MELT_DO_REGISTER_CPP_TTYPE
-     }#)
-    )
-  )
-
-(defun register_expanded_pragma (space name fun)
-  (debug "register_expanded_pragma start space=" space " name=" name " fun=" fun)
-  (ensure_cpp_ttype_tuple)
+    (foreach_in_multiple
+     (pragma_handler_tuple)
+     (comp :long ix)
+     (when ix
+	 (unless comp
+	   (setq lix ix)
+	   (setq ix (+i nbph 1))
+	   (void))))
+    (unless lix
+      (let ( (:long newnbph (+ nbph 16 (* 2 (/i nbph 8))))
+	     (newtup (make_multiple discr_multiple newnbph))
+	     )
+	(foreach_in_multiple
+	 (pragma_handler_tuple)
+	 (comp :long ix)
+	 (if ix (multiple_put_nth newtup ix comp)))
+	(setq pragma_handler_tuple newtup)
+	(setq lix nbph)
+	(setq nbph newnbph)
+	(void)
+	))
+    (put_int ph lix)
+    (multiple_put_nth pragma_handler_tuple lix ph)
+    (debug "add_pragma_handler ph=" ph " lix=" lix)
+    (return ph)
+    ))    
+
+
+(defun remove_pragma_handler (ph)
+  :doc #{Utility to remove a pragma handler $PH which should be a
+  $CLASS_GCC_PRAGMA or a boxed integer.}#
+  (if (is_integerbox ph)
+      (setq ph (multiple_nth pragma_handler_tuple (get_int ph))))
+  (if (is_a ph class_gcc_pragma)
+      (let ( (:long phrk (get_int ph))
+	     )
+	(if (== (multiple_nth pragma_handler_tuple phrk) ph)
+	    (multiple_put_nth pragma_handler_tuple phrk ()))))
   )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (export_values
+ add_pragma_handler
  at_end_of_this_melt_pass_first
  at_end_of_this_melt_pass_last
  at_exit_first
@@ -2397,9 +2367,10 @@ c_register_pragma_with_data (const char *space, const char *name,
  at_melt_attribute_last
  at_start_unit_first
  at_start_unit_last
- check_c_frontend
  hook_low_debug_value_at
  hook_override_gate
+ hook_process_pragma
+ hook_register_pragmas
  register_all_ipa_passes_end_first
  register_all_ipa_passes_end_last
  register_all_ipa_passes_start_first
@@ -2420,8 +2391,10 @@ c_register_pragma_with_data (const char *space, const char *name,
  register_override_gate_last
  register_pass_execution_first
  register_pass_execution_last
+ register_pragma_processor
  register_pre_genericize_first
  register_pre_genericize_last
+ remove_pragma_handler
  unregister_override_gate_first
  unregister_override_gate_last
  )
diff --git a/gcc/melt/xtramelt-ana-tree.melt b/gcc/melt/xtramelt-ana-tree.melt
index 469a98b9d8a..126ba3c27cc 100644
--- a/gcc/melt/xtramelt-ana-tree.melt
+++ b/gcc/melt/xtramelt-ana-tree.melt
@@ -1651,6 +1651,293 @@ pointer type node.}#
 (install_method discr_map_trees dbg_output dbgout_maptree_method)
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;           P R A G M A S
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cheader
+ #{ /* cheader for pragmas in warmelt-hooks.melt */
+ #include "cpplib.h"
+ #include "c-family/c-pragma.h"
+/*** 
+     We declare weak functions because they cannot be linked when we
+     use lto (it loses langage specific informations).  If you use one
+     of those functions you must check them to be not NULL.
+***/
+// Function pragma_lex is declared in c-family/c-pragma.h
+extern enum cpp_ttype pragma_lex (tree *) MELT_WEAK_ON_HOST;
+
+// Function c_register_pragma_with_expansion_and_data from c-family/c-pragma.h
+extern void
+c_register_pragma_with_expansion_and_data (const char *space,
+					   const char *name,
+					   pragma_handler_2arg handler,
+					   void *data) MELT_WEAK_ON_HOST;
+// Function c_register_pragma_with_data from c-family/c-pragma.h
+extern void
+c_register_pragma_with_data (const char *space, const char *name,
+			     pragma_handler_2arg handler,
+			     void *data) MELT_WEAK_ON_HOST;
+
+ static void
+ melt_register_pragmas_callback (void* gccdata ATTRIBUTE_UNUSED,
+			        void* userdata ATTRIBUTE_UNUSED)
+ {
+   melthookproc_HOOK_REGISTER_PRAGMAS ();
+   } /* end of melt_register_pragmas_callback */
+
+static void
+melt_pragma_process_callback(struct cpp_reader* ATTRIBUTE_UNUSED, void* data)
+{
+   long ix = (long) data;
+   melthookproc_HOOK_PROCESS_PRAGMA(ix);
+}
+
+ }#)
+
+
+(defun check_c_frontend (nam :cstring msg)
+  :doc #{utility function to check that we are indeed within a C or
+  C++ compiler, outside of @tt{lto1} but inside @tt{cc1} or
+  @tt{cc1plus}.}#
+  (assert_msg "check nam" (is_a nam class_named))
+  (let ( (:long good 0)
+	 )
+    (code_chunk
+     checkc_havepragmas_chk
+     #{ /* start check_c_frontend $CHECKC_HAVEPRAGMAS_CHK */
+#ifdef MELT_WEAK_ON_HOST
+     $GOOD = pragma_lex
+           && c_register_pragma_with_expansion_and_data
+           && c_register_pragma_with_data;
+#else
+#error check_c_frontend need MELT_WEAK_ON_HOST
+#endif
+     /* end check_c_frontend $CHECKC_HAVEPRAGMAS_CHK */
+     }#)
+    (debug "check_c_frontend good=" good " nam=" nam " msg=" msg)
+    (unless good
+      (error_at () "Can't use $1 ($2) outside of a C [cc1] or C++ [cc1plus] compiler -e.g. inside [lto1]"
+		nam msg)
+      (let ( (namstr (get_field :named_name nam))
+	     )
+	(assert_msg "check namstr" (is_string namstr) namstr nam)
+	(code_chunk
+	 checkc_fatalerror_chk
+	 #{ /* check_c_frontend $CHECKC_FATALERROR_CHK */
+	 melt_fatal_error("C or C++ frontend expected in %s (%s)",
+			  melt_string_str($NAMSTR),
+			  $MSG);
+	 }#)))
+    ))
+
+
+;; a variable to hold lazily the tuple of symbols for our pragma_lexer
+(defvar cpp_ttype_tuple)
+
+(defhook register_cpp_ttype (:long ix :cstring name) () :void
+  (assert_msg "check cpp_ttype_tuple" (is_multiple cpp_ttype_tuple) cpp_ttype_tuple)
+  (multiple_put_nth cpp_ttype_tuple ix
+		    (hook_named_symbol
+		     name
+		     (expr_chunk chk_meltcreate :long
+				 #{/*register_cpp_ttype*/ (long)MELT_CREATE}#)))
+  )
+
+(defun ensure_cpp_ttype_tuple ()
+  (if cpp_ttype_tuple (return))
+  (let ( (:long nbttype (expr_chunk chk_nbttype :long
+				    #{/*ensure_cpp_ttype_tuple*/ (long) N_TTYPES}#))
+	 (newcpptytuple (make_multiple discr_multiple nbttype))
+	 )
+    (setq cpp_ttype_tuple newcpptytuple)
+    (code_chunk
+     cpptypetuple_chk
+     #{ /* ensure_cpp_ttype_tuple $CPPTYPETUPLE_CHK */
+#define MELT_DO_REGISTER_CPP_TTYPE(CppNam) \
+   melthook_REGISTER_CPP_TTYPE($REGISTER_CPP_TTYPE, \
+			       CppNam, #CppNam);
+// macros used by TTYPE_TABLE from cpplib.h
+#ifndef TTYPE_TABLE
+#error TTYPE_TABLE not defined but expected
+#endif
+#define OP(Nam,Str) /*oper*/  MELT_DO_REGISTER_CPP_TTYPE(CPP_##Nam)
+#define TK(Nam,Typ) /*token*/ MELT_DO_REGISTER_CPP_TTYPE(CPP_##Nam)
+// the TTYPE_TABLE below is a long macro
+     TTYPE_TABLE
+#undef MELT_DO_REGISTER_CPP_TTYPE
+     }#)
+    )
+  )
+
+(defun pragma_lex ()
+  :doc #{Thin wrapper around @tt{pragma_lex} from
+  @tt{c-family/c-pragma.h}, to be called from pragma handling. Returns
+  the type, as a symbol, and secondarily the tree.}#
+  (let ( (:long trtyperank -1)
+	 (:tree tr (null_tree))
+	 )
+    (code_chunk
+     pragmalex_chk
+     #{ /* pragma_lex $PRAGMALEX_CHK */
+     if (!pragma_lex)
+       melt_fatal_error ("pragma_lex @%p called outside of C [cc1] or C++ compiler [cc1plus] e.g. from [lto1]",
+			 (void*) pragma_lex);
+     $TRTYPERANK = (long) pragma_lex (& ($TR));
+     }#)
+    (if trtyperank
+	(let ( (trtype (multiple_nth cpp_ttype_tuple trtyperank))
+	       )
+	  (debug "pragma_lex trtype=" trtype " tr=" tr)
+	  (return trtype tr)
+	  )
+      (return () tr)
+      )
+  ))
+
+
+(defclass class_gcc_expanded_pragma
+  :doc #{The $CLASS_GCC_EXPANDED_PRAGMA is for registered pragma
+  handlers with expansion, see
+  @code{c_register_pragma_with_expansion_and_data} in
+  @file{c-family/c-pragma.h} and also $CLASS_GCC_PLAIN_PRAGMA.}#
+  :super class_gcc_pragma
+  :fields ())
+
+
+(defclass class_gcc_plain_pragma
+  :doc #{The $CLASS_GCC_PLAIN_PRAGMA is for registered pragma handlers
+  without expansion, see @code{c_register_pragma_with_data} in
+  @file{c-family/c-pragma.h} and also $CLASS_GCC_EXPANDED_PRAGMA.}#
+  :super class_gcc_pragma
+  :fields ())
+
+
+(defun register_expanded_pragma (space name fun data)
+  :doc #{Register an expanded pragma using
+  @code{c_register_pragma_with_expansion_and_data} in given
+  $SPACE (default is :melt) with a given $NAME and closure $FUN and
+  $DATA. Return a newly added instance of
+  $CLASS_GCC_EXPANDED_PRAGMA. See also $REGISTER_PLAIN_PRAGMA.}#
+  (debug "register_expanded_pragma start space=" space " name=" name " fun=" fun " data=" data)
+  (check_c_frontend 'register_expanded_pragma "start")
+  (ensure_cpp_ttype_tuple)
+  (unless (is_a space class_symbol)
+    (setq space :melt))
+  (when (is_not_a space class_named)
+    (error_at () "register_expanded_pragma bad space for name $1"
+	      name)
+    (return))
+  (when (is_not_a name class_named)
+    (error_at () "register_expanded_pragma bad name $1"
+	      name)
+    (return))
+  (unless (is_closure fun)
+    (error_at () "register_expanded_pragma fail in space $1 name $2 - non closure fun"
+	      space name)
+    (return))
+  (let ( (ph (instance class_gcc_expanded_pragma
+		       :named_name name
+		       :gccpragma_handler fun
+		       :gccpragma_space space
+		       :gccpragma_data data))
+	 )
+    (add_pragma_handler ph)
+    )
+  )
+
+(defun register_plain_pragma (space name fun data)
+  :doc #{Register a plain (unexpanded) pragma using
+  @code{c_register_pragma_with_expansion_and_data} in given
+  $SPACE (default is :melt) with a given $NAME and closure $FUN and
+  $DATA. Return a newly added instance of
+  $CLASS_GCC_PLAIN_PRAGMA. See also $REGISTER_EXPANDED_PRAGMA.}#
+  (debug "register_plain_pragma start space=" space " name=" name " fun=" fun " data=" data)
+  (check_c_frontend 'register_plain_pragma "start")
+  (ensure_cpp_ttype_tuple)
+  (unless (is_a space class_symbol)
+    (setq space 'meltpragma))
+  (when (is_not_a space class_named)
+    (error_at () "register_plain_pragma bad space for name $1"
+	      name)
+    (return))
+  (when (is_not_a name class_named)
+    (error_at () "register_plain_pragma bad name $1"
+	      name)
+    (return))
+  (unless (is_closure fun)
+    (error_at () "register_plain_pragma fail in space $1 name $2 - non closure fun"
+	      space name)
+    (return))
+  (let ( (ph (instance class_gcc_plain_pragma
+		       :named_name name
+		       :gccpragma_handler fun
+		       :gccpragma_space space
+		       :gccpragma_data data))
+	 )
+    (add_pragma_handler ph)
+    )
+  )
+
+
+(defun real_pragma_processor (pragmatup)
+  (debug "real_pragma_processor start pragmatup=" pragmatup)
+  (foreach_in_multiple
+   (pragmatup)
+   (curpragma :long ix)
+   (cond
+    ( (null curpragma)
+      (void))
+    ( (is_a curpragma class_gcc_plain_pragma)
+      (let ( (:long lix (get_int curpragma) )
+	     (name (get_field :named_name curpragma))
+	     (space (get_field :gccpragma_space curpragma))
+	     (spacestr (get_field :named_name space))
+	     (namestr (get_field :named_name name))
+	     )
+	(assert_msg "check lix" (==i lix ix) lix ix curpragma)
+	(assert_msg "check spacestr" (is_string spacestr) space curpragma)
+	(assert_msg "check namestr" (is_string namestr) name curpragma)
+	(code_chunk
+	 plainpragma_chk
+	 #{ /* real_pragma_processor $PLAINPRAGMA_CHK */
+	 c_register_pragma_with_data
+	   (melt_string_str ($SPACESTR),
+	    melt_string_str ($NAMESTR),
+	    melt_pragma_process_callback,
+	    (void*) $LIX);
+	 }#)
+	)
+      )
+    ( (is_a curpragma class_gcc_expanded_pragma)
+      (let ( (:long lix (get_int curpragma))
+	     (name (get_field :named_name curpragma))
+	     (space (get_field :gccpragma_space curpragma))
+	     (spacestr (get_field :named_name space))
+	     (namestr (get_field :named_name name))
+	     )
+	(assert_msg "check lix" (==i lix ix) lix ix curpragma)
+	(assert_msg "check spacestr" (is_string spacestr) space curpragma)
+	(assert_msg "check namestr" (is_string namestr) name curpragma)
+	(code_chunk
+	 expandedpragma_chk
+	 #{ /* real_pragma_processor $EXPANDEDPRAGMA_CHK */
+	 c_register_pragma_with_expansion_and_data
+           (melt_string_str ($SPACESTR),
+            melt_string_str ($NAMESTR),
+            melt_pragma_process_callback,
+            (void*) $LIX) ;
+	 }#)
+	)
+      )
+    (:else
+     (assert_msg "bad curpragma" curpragma curpragma))
+    )
+   )
+  )
+
+;; see warmelt-hooks.melt and its hook_register_pragmas
+(register_pragma_processor real_pragma_processor)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TREE DIAGNOSTIC OUTPUT 
@@ -1673,6 +1960,9 @@ pointer type node.}#
 "pop_cfun()")
 
 
+(export_class class_gcc_expanded_pragma)
+(export_class class_gcc_plain_pragma)
+
 (export_values
  ;;in alphanumerical order
  ==t
@@ -1698,7 +1988,10 @@ pointer type node.}#
  maptree_size
  null_tree
  pop_cfun
+ pragma_lex
  push_cfun_decl
+ register_expanded_pragma
+ register_plain_pragma
  tree_addr_expr
  tree_array_ref
  tree_array_ref_full
@@ -1780,10 +2073,10 @@ pointer type node.}#
  tree_string_cst
  tree_type   
  tree_type_addr_space 
- tree_type_p
  tree_type_decl
  tree_type_decl_named
  tree_type_declaration
+ tree_type_p
  tree_types_compatible_p
  tree_uid
  tree_unsigned_char_type_node