2009-06-15 Basile Starynkevitch <basile@starynkevitch.net>

	[funmatcher expressions not working]
	* gcc/testsuite/melt/tfunmatch-1.melt: added funmatcher expr...
	* gcc/melt/warmelt-macro.melt: added sfmatx_fmatbind field into
	class_src_funmatchexpr for expand_funmatchexpr.
	* gcc/melt/warmelt-normatch.melt: or pattern expansion ok.




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

4 files changed, 19 insertions, 23 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 753dcba9f95..aa63e49dfc8 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,3 +1,10 @@
+2009-06-15  Basile Starynkevitch  <basile@starynkevitch.net>
+	[funmatcher expressions not working]
+	* testsuite/melt/tfunmatch-1.melt: added funmatcher expr...
+	* melt/warmelt-macro.melt: added sfmatx_fmatbind field into
+	class_src_funmatchexpr for expand_funmatchexpr.
+	* melt/warmelt-normatch.melt: or pattern expansion ok.
+
 2009-06-12  Basile Starynkevitch  <basile@starynkevitch.net>
 	[or pattern working]
 	* melt/warmelt-normatch.melt: normpat_orpat working...
diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt
index 4b02c853e06..f5fda39e6eb 100644
--- a/gcc/melt/warmelt-macro.melt
+++ b/gcc/melt/warmelt-macro.melt
@@ -79,6 +79,7 @@
 (defclass class_src_funmatchexpr
   :super class_src
   :fields (sfmatx_fmatcher		;the funmatcher
+	   sfmatx_fmatbind		;the funmatcher binding
 	   sfmatx_args			;the arguments
 ))
 
@@ -734,38 +735,29 @@
 
 ;;; expand a funmatcher expression
 ;;;; this is for funmatcher in expression contexts (not as patterns) 
-(defun expand_funmatchexpr (fmat sexpr env mexpander)
+(defun expand_funmatchexpr (fmat sexpr env mexpander opbind)
   (debug_msg sexpr "expand_funmatchexpr sexpr")
   (debug_msg fmat "expand_funmatchexpr fmat")
   (assert_msg "check sexpr" (is_a sexpr class_sexpr))
   (assert_msg "check env" (is_a env class_environment))
   (assert_msg "check mexpander" (is_closure mexpander))
   (assert_msg "check fmat" (is_a fmat class_funmatcher))
-  (compile_warning "@$@unimplemented expand_funmatchexpr" ())
   (let ( (scont (unsafe_get_field :sexp_contents sexpr))
 	 (sloc (unsafe_get_field :loca_location sexpr))
 	 (spair (pair_tail (list_first scont)))
 	 (soper (pair_head (list_first scont)))
 	 (xargtup (expand_restlist_as_tuple scont env mexpander))
-	 (fmatin (unsafe_get_field :amatch_in fmat))
 	 (fmatapp (unsafe_get_field :fmatch_applyf fmat))
 	 )
-    (if (!=i (multiple_length xargtup)
-	     (multiple_length fmatin))
-	(warning_strv sloc
-		      "bad argument number for funmatcher expression"_
-		      (unsafe_get_field :named_name fmat)))
-    (if (null fmatapp)
-	(progn
-	  (error_strv sloc
-		      "funmatcher used without applying function expansion"_
-		      (unsafe_get_field :named_name fmat))
-	  (return)))
+    (debug_msg xargtup "expand_funmatchexpr xargtup")
+    (debug_msg fmatapp "expand_funmatchexpr fmatapp")
+    (debug_msg opbind "expand_funmatchexpr opbind")
     ;; we need to build a specific funmatchexpr, because it is handled
     ;; differently from a simple application
     (let ( (res (instance class_src_funmatchexpr
 			  :src_loc sloc
 			  :sfmatx_fmatcher fmat
+			  :sfmatx_fmatbind opbind
 			  :sfmatx_args xargtup)) )
       (debug_msg res "funmatcher result")
       (return res)
@@ -830,7 +822,7 @@
 			    ))
 			( (is_a opbind class_funmatcher_binding)
 			  (let ( (fmatch (unsafe_get_field :fmbind_funmatcher opbind)) 
-				 (resf (expand_funmatchexpr fmatch sexpr env mexpander))
+				 (resf (expand_funmatchexpr fmatch sexpr env mexpander opbind))
 				 )
 			    (debug_msg resf "macroexpand_1 result for funmatcher resf")
 			    (return resf)
@@ -860,7 +852,7 @@
 				 (debug_msg resc "macroexpand_1 result for cmatch resc")
 				 (return resc)))
 			     ( (is_a val class_funmatcher)
-			       (let ( (resf (expand_funmatchexpr val sexpr env mexpander)) )
+			       (let ( (resf (expand_funmatchexpr val sexpr env mexpander opbind)) )
 				 (debug_msg resf "macroexpand_1 result for funmatch resf")
 				 (return resf)))
 			     (:else
@@ -1036,10 +1028,6 @@
 	    (patmacexpand_for_matcher (pair_tail curpair) fmat env sloc pctx)
 	    (debug_msg args "patternexpand_expr funmatcher args")
 	    (debug_msg pats "patternexpand_expr funmatcher pats")
-	    ;; maybe we should transmit to the pcomp something from
-	    ;; the defunmatcher, eg the name or expression of the
-	    ;; matching function
-	    (compile_warning "patternexpand_expr funmatcher perhaps we should have more of the defunmatcher..." ())
 	    (let ( (pcomp (instance class_srcpattern_funmatch
 				    :src_loc sloc
 				    :spac_operator fmat
diff --git a/gcc/melt/warmelt-normatch.melt b/gcc/melt/warmelt-normatch.melt
index dd22076df8e..4568227d150 100644
--- a/gcc/melt/warmelt-normatch.melt
+++ b/gcc/melt/warmelt-normatch.melt
@@ -921,7 +921,6 @@
 	     (debug_msg testercont "normpat_orpat.subhdler done testercont")
 	     )))
 	) 
-    (compile_warning "normpat_orpat is untested" ())
     (foreach_in_multiple 
      (disjpats)
      (subpat :long subix)
@@ -953,7 +952,6 @@
 	  (list_append testlist disjtester)
 	  (debug_msg disjtester "normpat_orpat handled disjtester")
 	  ))
-      (compile_warning "$@$incomplete normpat_orpat" ())
       )
     )
   (debug_msg recv "normpat_orpat recv end")
diff --git a/gcc/testsuite/melt/tfunmatch-1.melt b/gcc/testsuite/melt/tfunmatch-1.melt
index dfb4db1c8de..4fef8b1a3e2 100644
--- a/gcc/testsuite/melt/tfunmatch-1.melt
+++ b/gcc/testsuite/melt/tfunmatch-1.melt
@@ -32,6 +32,7 @@
 (defun applybiggereven (fmat :long x)
   (debug_msg fmat "applybiggereven fmat")
   (messagenum_dbg "applybiggereven x=" x)
+  (code_chunk apbigev #{ printf("applybiggereven x=%ld\n", $x); }#)
   (return fmat x)
 )
 
@@ -44,6 +45,7 @@
   matchbiggereven applybiggereven)
 	      
 
+#|
 (defun tfunmatch (o :long x)
   (debug_msg o "start tfunmatch o=")
   (messagenum_dbg "start tfunmatch x=" x)
@@ -59,5 +61,6 @@
 (tfunmatch 'one 1)
 (tfunmatch 'four 4)
 (tfunmatch 'ten 10)
-
+|#
+(isbiggereven 'six 6)
 ;; eof tfunmatch-1.melt
\ No newline at end of file