2010-03-25 Basile Starynkevitch <basile@starynkevitch.net>

	* gcc/melt/warmelt-first.melt: install_method warns when bad arguments.

	* gcc/melt/warmelt-base.melt: added warningmsg_strv

	* gcc/melt/warmelt-normatch.melt: added debug msg...



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

3 files changed, 53 insertions, 3 deletions

diff --git a/gcc/melt/warmelt-base.melt b/gcc/melt/warmelt-base.melt
index 7ff500fcb15..06a4bbb51f6 100644
--- a/gcc/melt/warmelt-base.melt
+++ b/gcc/melt/warmelt-base.melt
@@ -283,10 +283,19 @@ number $NUM opaque location number $LOC.}#
   )
 
 
-;; signal a plain error
+
+
+;; signal a plain warning with string
+(defprimitive warningmsg_strv (:cstring cmsg :value strv) :void
+  :doc #{Show a plain warning with raw message string $CMSG and string value $STRV.}#
+  #{warning (0, "MELT WARNING MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg),
+	  melt_string_str((melt_ptr_t)($strv)))}#
+  )
+
+;; signal a plain error with string
 (defprimitive errormsg_strv (:cstring cmsg :value strv) :void
   :doc #{Show a plain error with raw message string $CMSG and string value $STRV.}#
-  #{error("MELT ERROR MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg),
+  #{error ("MELT ERROR MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg),
 	  melt_string_str((melt_ptr_t)($strv)))}#
   )
 
@@ -984,6 +993,7 @@ significant iff ENABLE_CHECKING.}# #{(melt_application_depth() <
  warning_strv
  warning_plain
  warningmsg_plain
+ warningmsg_strv
  errormsg_plain
  errormsg_strv
  inform_strv
diff --git a/gcc/melt/warmelt-first.melt b/gcc/melt/warmelt-first.melt
index 8a27879c940..6ecf43f43f8 100644
--- a/gcc/melt/warmelt-first.melt
+++ b/gcc/melt/warmelt-first.melt
@@ -2937,7 +2937,46 @@ list of every element of the tuple transformed by $TRANSF.}#
 		  (let ( (newmapdict (make_mapobject discr_method_map 35)) )
 		    (unsafe_put_fields cla :disc_methodict newmapdict)
 		    (mapobject_put newmapdict sel fun)
-		    ))))))
+		    )))
+	    (let (
+		  (clanam (get_field :named_name cla))
+		  (selnam (get_field :named_name sel))
+		  )
+	      (code_chunk 
+	       warn_non_fun
+	       #{
+	       warning (0, 
+			"MELT INSTALL_METHOD WARNING [#%ld] non-function in %s for %s",
+			melt_dbgcounter,
+			melt_string_str((melt_ptr_t) $CLANAM),
+			melt_string_str((melt_ptr_t) $SELNAM)) ;
+	       }#)
+	      (shortbacktrace_dbg "INSTALL_METHOD failing on non-function" 20)
+	      )
+	    )
+	(let ( (clanam (get_field :named_name cla))
+	       )
+	  (code_chunk 
+	   warn_non_sel
+	   #{
+	   warning (0, 
+		    "MELT INSTALL_METHOD WARNING [#%ld] non-function in %s for %s",
+		    melt_dbgcounter,
+		    melt_string_str((melt_ptr_t) $CLANAM)) ;
+	   }#)
+	  (shortbacktrace_dbg "INSTALL_METHOD failing on non-selector" 20)
+	  )
+	)
+    (progn
+      (code_chunk 
+       warn_non_discr
+       #{
+       warning (0, 
+		"MELT INSTALL_METHOD WARNING [#%ld] non-discriminant",
+		melt_dbgcounter)	;
+       }#)
+      (shortbacktrace_dbg "INSTALL_METHOD failing on non-discriminant" 20)
+      ))
   )
 
 
diff --git a/gcc/melt/warmelt-normatch.melt b/gcc/melt/warmelt-normatch.melt
index 013b1004788..6f98e279230 100644
--- a/gcc/melt/warmelt-normatch.melt
+++ b/gcc/melt/warmelt-normatch.melt
@@ -4217,6 +4217,7 @@ the data of the $STEP with an extra context $CTX.}#
 	    (debug_msg sortedvarocc  "translate_matchcase sortedvarocc")
 	    (put_fields 
 	     stepsucc :mstepsuccess_varocc sortedvarocc))
+	  (debug_msg stepsucc "translate_matchcase stepsucc")
 	  (put_then_match mstep stepsucc)
 	  (debug_msg mstep "translate_matchcase updated mstep")
 	  (if prevstep