2009-07-21 Basile Starynkevitch <basile@starynkevitch.net>

	[heterogenous patterns compiled better]
	* melt-runtime.c: Corrected typo in comment.
	* melt/warmelt-first.melt: re-added dbgcounter in debug_msg
	messages.
	* melt/warmelt-normatch.melt: scanpat_srcpatcomposite compute the
	right ctype for subpatterns.
	* melt/ana-base.melt: added tree_of_type cmatcher.
	* melt/ana-simple.melt: added gimple_assign_cast pattern to
	makegreen_transform.
	* testsuite/melt/tgreenprint.c: added simple_fprint_stdout.



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

7 files changed, 71 insertions, 8 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index a53c48de17f..dd787291064 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,4 +1,16 @@
 
+2009-07-21  Basile Starynkevitch  <basile@starynkevitch.net>
+	[heterogenous patterns compiled better]
+	* melt-runtime.c: Corrected typo in comment.
+	* melt/warmelt-first.melt: re-added dbgcounter in debug_msg
+	messages.
+	* melt/warmelt-normatch.melt: scanpat_srcpatcomposite compute the
+	right ctype for subpatterns.
+	* melt/ana-base.melt: added tree_of_type cmatcher.
+	* melt/ana-simple.melt: added gimple_assign_cast pattern to
+	makegreen_transform.
+	* testsuite/melt/tgreenprint.c: added simple_fprint_stdout.
+
 2009-07-20  Basile Starynkevitch  <basile@starynkevitch.net>
 	* melt-runtime.c (meltgc_gimple_gate, meltgc_gimple_execute)
 	(meltgc_rtl_gate, meltgc_rtl_execute, meltgc_simple_ipa_gate)
diff --git a/gcc/melt-runtime.c b/gcc/melt-runtime.c
index 734c7e070c6..8544a87758f 100644
--- a/gcc/melt-runtime.c
+++ b/gcc/melt-runtime.c
@@ -98,7 +98,7 @@ int flag_melt_debug;
    This code does not yet compile in plugin mode, unless the gengtype
    is suitably patched.
 
-   un addition, libiberty is not fully available from a plugin. So we
+   in addition, libiberty is not fully available from a plugin. So we
    need to reproduce here some functions provided in libiberty.h
 **/
 char *
diff --git a/gcc/melt/ana-base.melt b/gcc/melt/ana-base.melt
index 06d217585a7..aace3b5cd84 100644
--- a/gcc/melt/ana-base.melt
+++ b/gcc/melt/ana-base.melt
@@ -643,6 +643,18 @@
   }#
 )
 
+
+;;;;;;;;;;;;;;;;
+(defcmatcher tree_of_type 
+  (:tree tr)
+  (:tree typetr)
+  treeoftype
+  ;; test expansion
+  #{ ($tr) != NULL }#
+  ;; fill expansion
+  #{ $typetr = TREE_TYPE($tr); }#
+)
+
 ;;;;;;;;;;;;;;;;
 ;; similarily pattern (tree_variable_decl <funame>)
 (defcmatcher tree_variable_decl 
@@ -1620,6 +1632,7 @@
  tree_block
  tree_content 
  tree_decl
+ tree_of_type
  tree_function_decl 
  tree_integer_cst
  tree_integer_type
diff --git a/gcc/melt/ana-simple.melt b/gcc/melt/ana-simple.melt
index 9c6466d3fa1..7dd51ca268c 100644
--- a/gcc/melt/ana-simple.melt
+++ b/gcc/melt/ana-simple.melt
@@ -48,13 +48,25 @@
    (eachgimple_in_basicblock 
     (bb)
     (:gimple g)
-    (debuggimple "makegreen_transform g" g)
     (match g
+	   (?(gimple_assign_cast 
+	      ?(as ?lhs 
+		   ?(tree_of_type ?ltype))
+	      ?rhs)
+	     (debugtree "makegreen_transform assign cast lhs" lhs)
+	     (debugtree "makegreen_transform assign cast ltype" ltype)
+	     (debugtree "makegreen_transform assign cast rhs" rhs)
+	     )
+	   (?(gimple_assign_single  ?lhs ?rhs)
+	     (debugtree "makegreen_transform assign single lhs" lhs)
+	     (debugtree "makegreen_transform assign single rhs" rhs)
+	     )
 	   (?(gimple_call ?lhs ?callfndcl ?nbargs)
 	     (debugtree "makegreen_transform call lhs" lhs)
 	     (debugtree "makegreen_transform call fndecl" callfndcl)
 	     )
 	   (?_
+	    (debuggimple "makegreen_transform unmatched g" g)
 	    )
 	   )
     )
@@ -1015,4 +1027,5 @@
 
 (initial_command_install smallana_command "smallana")
 
+
 ;; eof ana-simple.melt
\ No newline at end of file
diff --git a/gcc/melt/warmelt-first.melt b/gcc/melt/warmelt-first.melt
index 039a943bb9a..77c01e3f55c 100644
--- a/gcc/melt/warmelt-first.melt
+++ b/gcc/melt/warmelt-first.melt
@@ -3784,7 +3784,7 @@
 		      }#)
 	  (if nulloutfile 
 	      (progn 
-		(shortbacktrace_dbg "debug_msg_fun null output file" 50)
+		(shortbacktrace_dbg "debug_msg_fun null output file" 5)
 		(setq out (get_field :sysdata_stderr initial_system_data))
 		)))
 	(let ( 
@@ -3795,6 +3795,8 @@
 	      (:long framdepth (the_framedepth)) 
 	      )
 	  (add2out_strconst out "!!!!****####")
+	  (add2out_longdec out dbgcounter)
+	  (add2out_strconst out "#^")
 	  (add2out_longdec out (-i framdepth 1))
 	  (add2out_strconst out ":")
 	  (if filenam
diff --git a/gcc/melt/warmelt-normatch.melt b/gcc/melt/warmelt-normatch.melt
index cd2014f6880..88e5ae93b4c 100644
--- a/gcc/melt/warmelt-normatch.melt
+++ b/gcc/melt/warmelt-normatch.melt
@@ -172,6 +172,7 @@
 ;; scanning an as pattern
 (defun scanpat_srcpatas (recv psloc ctyp pcn)
   (debug_msg recv "scanpat_srcpatas recv")
+  (debug_msg ctyp "scanpat_srcpatas ctyp")
   (assert_msg "check pcn" (is_a pcn class_patterncontext))
   (assert_msg "check recv" (is_a recv class_srcpattern_as))
   (let ( (sloc (unsafe_get_field :src_loc recv))
@@ -280,10 +281,13 @@
 ;; scanning a composite pattern 
 (defun scanpat_srcpatcomposite (recv psloc ctyp pcn)
   (assert_msg "check pcn" (is_a pcn class_patterncontext))
+  (debug_msg recv "scanpat_srcpatcomposite start recv")
+  (debug_msg ctyp "scanpat_srcpatcomposite start ctyp")
+  (assert_msg "check ctyp" (is_a ctyp class_ctype))
   (assert_msg "check recv" (is_a recv class_srcpattern_composite))
-  (debug_msg recv "scanpat_srcpatcomposite recv")
   (let ( (sloc (unsafe_get_field :src_loc recv))
 	 (soper (let ((sop (unsafe_get_field :spac_operator recv)))
+		  (debug_msg sop "scanpat_srcpatcomposite soper")
 		  (assert_msg "check soper" (is_a sop class_any_matcher))
 		  sop))
 	 (sins (unsafe_get_field :spac_inargs recv)) 
@@ -300,13 +304,19 @@
 	 (ncx (unsafe_get_field :pctn_normctxt pcn))
 	 (bindlist (unsafe_get_field :pctn_bindlist pcn))
 	 )
-    (assert_msg "check ctyp" (is_a ctyp class_ctype))
     (assert_msg "check matctyp" (is_a matctyp class_ctype))
+    (debug_msg matout "scanpat_srcpatcomposite matout")
     (cond ((!= ctyp matctyp)
 	   (error_strv sloc "invalid ctype in composite pattern - expecting"
 		       (unsafe_get_field :named_name matctyp))
 	   (warning_strv sloc "got ctype"
 			 (unsafe_get_field :named_name ctyp))
+	   (debug_msg ctyp "scanpat_srcpatcomposite mismatched ctyp")
+	   (debug_msg matctyp "scanpat_srcpatcomposite mismatched matctyp")
+	   (debug_msg recv "scanpat_srcpatcomposite mismatched recv")
+	   ;;@@@TEMPORARY@@
+	   (assert_msg "temporary hack scanpat_srcpatcomposite mismatch crash here" ())
+	   ;;
 	   (return)))
     (multicall 
      (nins bindins)
@@ -314,12 +324,20 @@
      (debug_msg nins "scanpat_srcpatcomposite nins")
      (if bindins (list_append2list bindlist bindins))
      (debug_msg souts "scanpat_srcpatcomposite souts")
+     (debug_msg matout "scanpat_srcpatcomposite matout")
      (foreach_in_multiple
       (souts)
       (pout :long ix)
-      (debug_msg pout "scanpat_srcpatcomposite pout")
-      (scan_pattern pout sloc ctyp pcn)
-      )
+      (debug_msg pout "scanpat_srcpatcomposite before scan_pattern pout")
+      (let ( (curobind (multiple_nth matout ix)) 
+	     (curctype (get_field :fbind_type curobind))
+	     )
+	(debug_msg curobind "scanpat_srcpatcomposite curobind")
+	(debug_msg curctype "scanpat_srcpatcomposite curctype")
+	(assert_msg "check curctype" (is_a curctype class_ctype))
+	(scan_pattern pout sloc curctype pcn)
+	(debug_msg pout "scanpat_srcpatcomposite after scan_pattern pout")
+	))
      (debug_msg recv "scanpat_srcpatcomposite end recv")
      )))
 (install_method class_srcpattern_composite scan_pattern scanpat_srcpatcomposite)
diff --git a/gcc/testsuite/melt/tgreenprint.c b/gcc/testsuite/melt/tgreenprint.c
index a3e5d55c8d1..fa5f1ff0f74 100644
--- a/gcc/testsuite/melt/tgreenprint.c
+++ b/gcc/testsuite/melt/tgreenprint.c
@@ -14,6 +14,11 @@
 #include <stdio.h>
 #include <stdlib.h>
 
+void simple_fprint_stdout(int p)
+{
+  fprintf (stdout, "simple fprint stdout p=%d\n", p);
+}
+
 static inline void
 say_str_int (FILE* f, const char* str, int n)
 {