2014-10-27 Basile Starynkevitch <basile@starynkevitch.net>

	* melt/warmelt-macro.melt (mexpand_let): For :macro bindings, stop
	the expansion on error before and after
	melt_delayed_macro_expander.

	* testsuite/melt/t-treecode.melt: Simplified, but still don't work.



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

3 files changed, 278 insertions, 253 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 15977e6a56a..5e5dec204df 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,4 +1,11 @@
 
+2014-10-27  Basile Starynkevitch  <basile@starynkevitch.net>
+	* melt/warmelt-macro.melt (mexpand_let): For :macro bindings, stop
+	the expansion on error before and after
+	melt_delayed_macro_expander.
+
+	* testsuite/melt/t-treecode.melt: Simplified, but still don't work.
+
 2014-10-25  Basile Starynkevitch  <basile@starynkevitch.net>
 	* testsuite/melt/t-treecode.melt: Simplified to use a few
 	treecodes but still don't work!
diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt
index c18e48976c9..fc76f9dd6b0 100644
--- a/gcc/melt/warmelt-macro.melt
+++ b/gcc/melt/warmelt-macro.melt
@@ -7185,15 +7185,25 @@ applications of @code{/i} primitives.}#
 				     "\n.. mexpanderm=" debug_less mexpanderm
 				     "\n.. macbind=" macbind)
 			      (shortbacktrace_dbg "mexpand_let:mexpanser" 25)
+			      (when (>i (melt_error_counter) 0)
+				(debug "mexpand_let:mexpanser" " loc=" loc " errored")
+				(error_at loc "MELT will not expand LET :macro $1 with #$2 errors"
+					  macsymb (melt_error_counter))
+				(return ()))
 			      (debug "mexpand_let:mexpanser before melt_delayed_macro_expander"
 				     " maclist=" maclist "\n.. macbind=" macbind)
 			      (melt_delayed_macro_expander macbind maclist envm mexpanderm modctx)
-			      (debug "mexpand_let:mexpanser after melt_delayed_macro_expander"
+			      (debug "mexpand_let:mexpanser" " loc=" loc " after melt_delayed_macro_expander"
 				     " maclist=" maclist "\n.. macbind=" macbind)
+			      (when (>i (melt_error_counter) 0)
+				(debug "mexpand_let:mexpanser" " loc=" loc " delayerrored")
+				(error_at loc "MELT will not expand LET :macro $1 with #$2 errors after delayed expansion"
+					  macsymb (melt_error_counter))
+				(return ()))
 			      (let ( (mclos (get_field :mbind_expanser macbind))
 				     (locm (get_field :loca_location sexprm))
 				     )
-				(debug "mexpand_let:mexpanser"
+				(debug "mexpand_let:mexpanser" " afterdelay"
 				       " loc=" loc " locm=" locm
 				       "\n.. mclos=" mclos
 				       "\n.. mexpanser=" mexpanser
@@ -7202,6 +7212,10 @@ applications of @code{/i} primitives.}#
 				  (error_at locm "failed to macro-expand LET :macro $1" macsymb)
 				  (warning_at loc "failed to expand LET :macro $1 defined here" macsymb)
 				  (return))
+				(debug "mexpand_let:mexpanser"
+				       " beforemulticall"
+				       " loc=" loc " locm=" locm
+				       " mclos=" mclos " sexprm=" sexprm)
 				(multicall 
 				 (expmac othermac)
 				 (mclos sexprm envm mexpanderm modctxm)
diff --git a/gcc/testsuite/melt/t-treecode.melt b/gcc/testsuite/melt/t-treecode.melt
index 09c7ac04829..af442cbe4d8 100644
--- a/gcc/testsuite/melt/t-treecode.melt
+++ b/gcc/testsuite/melt/t-treecode.melt
@@ -39,108 +39,38 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \
 
 
 (let (      
-      (:macro  gcc_tree_code (sexp env mexpander modctx)	      
-	       (debug "gcc_tree_code:macro2" " sexp=" sexp)
-	       (let (
-		     (sloc (get_field :loca_location sexp))
-		     (sexcont (get_field :sexp_contents sexp))
-		     (xargs (expand_restlist_as_tuple sexcont env mexpander modctx))
-		     (namecod (multiple_nth xargs 0))
-		     (strcod (multiple_nth xargs 1))
-		     (typcod (multiple_nth xargs 2))
-		     (nargcod (multiple_nth xargs 3))
-		     (nbargs (multiple_length xargs))
-		     (namev (get_field :named_name namecod))
-		     (treenamev (string4out discr_string "tree_" namev))
-		     (treesymb (create_symbolstr treenamev))
-		     (statesymb (create_symbolstr (string4out discr_string "treestate_" namev)))
-		     )
-		 (when (!=i 4 nbargs)
-		   (error_at sloc "GCC_TREE_CODE need four arguments, got $1" xargs)
-		   (return))
-		 (debug "gcc_tree_code:macro2"
-			" namecod=" namecod
-			" strcod=" strcod
-			" typcod=" typcod
-			" nargcod=" nargcod
-			"\n.. treesymb=" treesymb
-			"\n.. bind:" (find_env env treesymb))
-		 (assert_msg "check namev" (is_string namev) namev namecod sexp)
-		 (unless (find_env env treesymb)
-		   (cond
-		    ;; tcc_exceptional, no automatic sub-trees
-		    ( (== typcod 'tcc_exceptional)
-		      (let
-			  (
-			   (xcmatchdoc
-			    (let
-				(
-				 (d
-				  (substitute_sexpr
-				   '#{Generated tcc_exceptional $TREESYMB cmatcher.}#
-				   (lambda (symb)
-				     (debug "gcc_tree_code:macro2-lambdasubstdoc symb=" symb)
-				     (if (== symb 'treesymb)
-					 (get_field :named_name treesymb)
-				       symb))))
-				 )
-			      (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xcmatchdoc=" d)
-			      d))
-			   (xmatexp
-			    (let
-				(
-				 (e
-				  (substitute_sexpr
-				   '#{ /* generated exceptional $TREESYMB tester ? */
-				   $TR && TREE_CODE($TR) == $NAMECOD }#
-				   (lambda (symb)
-				     (debug "gcc_tree_code:macro2-lambdasubstexp symb=" symb)
-				     (cond
-				      ( (== symb 'treesymb)
-					(clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
-					)
-				      ( (== symb 'namecod)
-					(clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
-					)
-				      (:else
-				       symb)))
-				   ))
-				 )
-			      (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xmatexp=" e)
-			      e))
-			   (xcmatcher
-			    `(defcmatcher ,treesymb
-			       (:tree tr)
-			       ()
-			       ,statesymb
-			       :doc ,xcmatchdoc
-			       ;; match-expander
-			       ,xmatexp
-			       ))
-			   (xexport `(export_values ,treesymb))
-			   )
-			(put_fields xcmatcher :loca_location sloc)
-			(put_fields xexport :loca_location sloc)
-			(debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xcmatcher=" debug_more xcmatcher
-			       "\n.. xexport=" xexport)
-			(let (
-			      (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
-			      (rexport (macroexpand_1 xexport env mexpander modctx))
-			      )
-			  (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional rmatch=" rmatch
-				 "\n.. rexport=" rexport)
-			  (return rmatch (tuple rexport))
-			  ))
-		      )
-		    ;; tcc_constant & tcc_declaration, without sub-trees
-		    (
-		     (or (== typcod 'tcc_constant)
-			 (== typcod 'tcc_declaration)
-			 )
-		     (if (>i (get_int nargcod) 0)
-			 (error_at sloc "GCC_TREE_CODE $1 of tcc_constant or tcc_declaration type with non-zero arity $2"
-				   treesymb nargcod
-				   ))
+      (:macro gcc_tree_code (sexp env mexpander modctx)
+	      (debug "gcc_tree_code:macro2" ": sexp=" sexp)
+	      (let (
+		    (sloc (get_field :loca_location sexp))
+		    (sexcont (get_field :sexp_contents sexp))
+		    (xargs (expand_restlist_as_tuple sexcont env mexpander modctx))
+		    (namecod (multiple_nth xargs 0))
+		    (strcod (multiple_nth xargs 1))
+		    (typcod (multiple_nth xargs 2))
+		    (nargcod (multiple_nth xargs 3))
+		    (nbargs (multiple_length xargs))
+		    (namev (get_field :named_name namecod))
+		    (treenamev (string4out discr_string "tree_" namev))
+		    (treesymb (create_symbolstr treenamev))
+		    (statesymb (create_symbolstr (string4out discr_string "treestate_" namev)))
+		    )
+		(when (!=i 4 nbargs)
+		  (error_at sloc "GCC_TREE_CODE need four arguments, got $1" xargs)
+		  (return))
+		(debug "gcc_tree_code:macro2"
+		       "; namecod=" namecod
+		       " strcod=" strcod
+		       " typcod=" typcod
+		       " nargcod=" nargcod
+		       "\n.. treesymb=" treesymb
+		       "\n.. bind:" (find_env env treesymb))
+		(assert_msg "check namev" (is_string namev) namev namecod sexp)
+		(unless (find_env env treesymb)
+		  (cond
+		   ;; tcc_exceptional, no automatic sub-trees
+		   ( (== typcod 'tcc_exceptional)
+		     (debug "gcc_tree_code:macro2" "; exceptional namev=" namev)
 		     (let
 			 (
 			  (xcmatchdoc
@@ -148,24 +78,24 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \
 			       (
 				(d
 				 (substitute_sexpr
-				  '#{Generated simple $TYPCOD $TREESYMB cmatcher.}#
+				  '#{Generated tcc_exceptional $TREESYMB cmatcher.}#
 				  (lambda (symb)
-				    (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
-				    (if (== symb 'typcod)
-					(get_field :named_name typcod)
+				    (debug "gcc_tree_code:macro2-lambdasubstdoc symb=" symb)
+				    (if (== symb 'treesymb)
+					(get_field :named_name treesymb)
 				      symb))))
 				)
-			     (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xcmatchdoc=" d)
+			     (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional xcmatchdoc=" d)
 			     d))
 			  (xmatexp
 			   (let
 			       (
 				(e
 				 (substitute_sexpr
-				  '#{ /* generated simple $TREESYMB tester ? */
+				  '#{ /* generated exceptional $TREESYMB tester ? */
 				  $TR && TREE_CODE($TR) == $NAMECOD }#
 				  (lambda (symb)
-				    (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
+				    (debug "gcc_tree_code:macro2-lambdasubstexp symb=" symb)
 				    (cond
 				     ( (== symb 'treesymb)
 				       (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
@@ -177,7 +107,7 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \
 				      symb)))
 				  ))
 				)
-			     (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xmatexp=" e)
+			     (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional xmatexp=" e)
 			     e))
 			  (xcmatcher
 			   `(defcmatcher ,treesymb
@@ -192,163 +122,237 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \
 			  )
 		       (put_fields xcmatcher :loca_location sloc)
 		       (put_fields xexport :loca_location sloc)
-		       (debug "gcc_tree_code:macro2" " sloc=" sloc "; constdecl xcmatcher=" debug_more xcmatcher
+		       (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional xcmatcher=" debug_more xcmatcher
 			      "\n.. xexport=" xexport)
 		       (let (
 			     (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
 			     (rexport (macroexpand_1 xexport env mexpander modctx))
 			     )
-			 (debug "gcc_tree_code:macro2" " sloc=" sloc "; rmatch=" rmatch
+			 (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional rmatch=" rmatch
 				"\n.. rexport=" rexport)
 			 (return rmatch (tuple rexport))
 			 ))
-		     
 		     )
-		    ;; For fixed tcc_reference, tcc_expression,
-		    ;; tcc_comparison, tcc_unary, tcc_binary,
-		    ;; tcc_statement.  They use the arity fourth
-		    ;; argument, and we extract sub-tree operands.
-		    (
-		     (or (== typcod 'tcc_reference)
-			 (== typcod 'tcc_expression)
-			 (== typcod 'tcc_unary)
-			 (== typcod 'tcc_binary)
-			 (== typcod 'tcc_statement)
-			 )
-		     (let
-			 (
-			  (xcmatchdoc
-			   (let
-			       (
-				(d
-				 (substitute_sexpr
-				  '#{Generated fixed $TYPCOD $TREESYMB cmatcher of arity $NARGCOD.}#
-				  (lambda (symb)
-				    (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
-				    (cond
-				     ( (== symb 'typcod)
-				       typcod)
-				     ( (== symb 'nargcod)
-				       nargcod)
-				     (:else symb))
-				    )))
-				)
-			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xcmatchdoc=" d)
-			     d))
-			  (xmatexp
-			   (let
-			       (
-				(e
-				 (substitute_sexpr
-				  '#{ /* generated fixed $TREESYMB tester ? */
-				  $TR && TREE_CODE($TR) == $NAMECOD }#
-				  (lambda (symb)
-				    (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
-				    (cond
-				     ( (== symb 'treesymb)
-				       (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
-				       )
-				     ( (== symb 'namecod)
-				       (clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
-				       )
-				     ( (== symb 'nargcod)
-				       nargcod)
-				     (:else
-				      symb)))
+		   ;; tcc_constant & tcc_declaration, without sub-trees
+		   (
+		    (or (== typcod 'tcc_constant)
+			(== typcod 'tcc_declaration)
+			)
+		    (debug "gcc_tree_code:macro2" "; simple namev=" namev)
+		    (if (>i (get_int nargcod) 0)
+			(error_at sloc "GCC_TREE_CODE $1 of tcc_constant or tcc_declaration type with non-zero arity $2"
+				  treesymb nargcod
 				  ))
-				)
-			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatexp=" e)
-			     e))
-			  (xlistfill (make_list discr_list))
-			  (tupopervar
-			   (let ( (:long narity (get_int nargcod))
-				  ( tv (make_multiple discr_multiple narity))
-				  )
-			     (foreach_long_upto
-			      (1 narity)
-			      (:long ix)
-			      (let ( (:long previx (-i ix 1))
-				     (opnamstr (string4out discr_string "TROPERAND" previx))
-				     (opnamsymb (create_symbolstr opnamstr))
-				     )
-				(multiple_put_nth tv previx opnamsymb)
-				(let ( (tr 'tr)
-				       )
-				  (add2list xlistfill ##{ $OPNAMSYMB = TREE_OPERAND($TR, $PREVIX)}#
-					    ";\n")
-				  )
-				)
-			      (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed tupopervar=" tv
-				     "\n.. updated xlistfill=" xlistfill)
-			      tv
-			      )))
-			  (xmatfill
-			   (let ( (e (substitute_sexpr
-				      '#{ /* generated fixed $TREESYMB filler ! */
-				      $XLISTFILL
-				      /* end of generated fixed $TREESYMB filler */}#
-				      (lambda (symb)
-					(debug "gcc_tree_code:macro2-lambdasubstfixfiller symb=" symb)
-					(cond
-					 ( (== symb 'treesymb)
-					   (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
-					   )
-					 ( (== symb 'xlistfill)
-					   xlistfill)
-					 (:else symb))
-					)))
-				  )
-			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatfill=" e)
-			     e
-			     )
-			   )
-			  (xcmatcher
-			   (let ( (m
-				   `(defcmatcher ,treesymb
-				      (:tree tr)
-				      (:tree ,tupopervar)
-				      ,statesymb
-				      :doc ,xcmatchdoc
-				      ;; match-expander
-				      ,xmatexp
-				      ;; match-filler
-				      ,xmatfill
-				      ))
-				  )
-			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xcmatcher=" m)
-			     m))
-			  (xexport `(export_values ,treesymb))
+		    (let
+			(
+			 (xcmatchdoc
+			  (let
+			      (
+			       (d
+				(substitute_sexpr
+				 '#{Generated simple $TYPCOD $TREESYMB cmatcher.}#
+				 (lambda (symb)
+				   (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
+				   (if (== symb 'typcod)
+				       (get_field :named_name typcod)
+				     symb))))
+			       )
+			    (debug "gcc_tree_code:macro2" "; sloc=" sloc "; constdecl xcmatchdoc=" d)
+			    d))
+			 (xmatexp
+			  (let
+			      (
+			       (e
+				(substitute_sexpr
+				 '#{ /* generated simple $TREESYMB tester ? */
+				 $TR && TREE_CODE($TR) == $NAMECOD }#
+				 (lambda (symb)
+				   (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
+				   (cond
+				    ( (== symb 'treesymb)
+				      (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
+				      )
+				    ( (== symb 'namecod)
+				      (clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
+				      )
+				    (:else
+				     symb)))
+				 ))
+			       )
+			    (debug "gcc_tree_code:macro2" "; sloc=" sloc "; constdecl xmatexp=" e)
+			    e))
+			 (xcmatcher
+			  `(defcmatcher ,treesymb
+			     (:tree tr)
+			     ()
+			     ,statesymb
+			     :doc ,xcmatchdoc
+			     ;; match-expander
+			     ,xmatexp
+			     ))
+			 (xexport `(export_values ,treesymb))
+			 )
+		      (put_fields xcmatcher :loca_location sloc)
+		      (put_fields xexport :loca_location sloc)
+		      (debug "gcc_tree_code:macro2" "; sloc=" sloc "; constdecl xcmatcher=" debug_more xcmatcher
+			     "\n.. xexport=" xexport)
+		      (let (
+			    (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
+			    (rexport (macroexpand_1 xexport env mexpander modctx))
+			    )
+			(debug "gcc_tree_code:macro2" "; sloc=" sloc "; rmatch=" rmatch
+			       "\n.. rexport=" rexport)
+			(return rmatch (tuple rexport))
+			))
+		     
+		    )
+		   ;; For fixed tcc_reference, tcc_expression,
+		   ;; tcc_comparison, tcc_unary, tcc_binary,
+		   ;; tcc_statement.  They use the arity fourth
+		   ;; argument, and we extract sub-tree operands.
+		   (
+		    (or (== typcod 'tcc_reference)
+			(== typcod 'tcc_expression)
+			(== typcod 'tcc_unary)
+			(== typcod 'tcc_binary)
+			(== typcod 'tcc_statement)
+			)
+		    (debug "gcc_tree_code:macro2" "; fixed namev=" namev)
+		    (let
+			(
+			 (xcmatchdoc
+			  (let
+			      (
+			       (d
+				(substitute_sexpr
+				 '#{Generated fixed $TYPCOD $TREESYMB cmatcher of arity $NARGCOD.}#
+				 (lambda (symb)
+				   (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
+				   (cond
+				    ( (== symb 'typcod)
+				      typcod)
+				    ( (== symb 'nargcod)
+				      nargcod)
+				    (:else symb))
+				   )))
+			       )
+			    (debug "gcc_tree_code:macro2" "; sloc=" sloc "; fixed xcmatchdoc=" d)
+			    d))
+			 (xmatexp
+			  (let
+			      (
+			       (e
+				(substitute_sexpr
+				 '#{ /* generated fixed $TREESYMB tester ? */
+				 $TR && TREE_CODE($TR) == $NAMECOD }#
+				 (lambda (symb)
+				   (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
+				   (cond
+				    ( (== symb 'treesymb)
+				      (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
+				      )
+				    ( (== symb 'namecod)
+				      (clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
+				      )
+				    ( (== symb 'nargcod)
+				      nargcod)
+				    (:else
+				     symb)))
+				 ))
+			       )
+			    (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatexp=" e)
+			    e))
+			 (xlistfill (make_list discr_list))
+			 (tupopervar
+			  (let ( (:long narity (get_int nargcod))
+				 ( tv (make_multiple discr_multiple narity))
+				 )
+			    (foreach_long_upto
+			     (1 narity)
+			     (:long ix)
+			     (let ( (:long previx (-i ix 1))
+				    (opnamstr (string4out discr_string "TROPERAND" previx))
+				    (opnamsymb (create_symbolstr opnamstr))
+				    )
+			       (multiple_put_nth tv previx opnamsymb)
+			       (let ( (tr 'tr)
+				      )
+				 (add2list xlistfill ##{ $OPNAMSYMB = TREE_OPERAND($TR, $PREVIX)}#
+					   ";\n")
+				 )
+			       )
+			     (debug "gcc_tree_code:macro2" "; sloc=" sloc "; fixed tupopervar=" tv
+				    "\n.. updated xlistfill=" xlistfill)
+			     tv
+			     )))
+			 (xmatfill
+			  (let ( (e (substitute_sexpr
+				     '#{ /* generated fixed $TREESYMB filler ! */
+				     $XLISTFILL
+				     /* end of generated fixed $TREESYMB filler */}#
+				     (lambda (symb)
+				       (debug "gcc_tree_code:macro2-lambdasubstfixfiller symb=" symb)
+				       (cond
+					( (== symb 'treesymb)
+					  (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
+					  )
+					( (== symb 'xlistfill)
+					  xlistfill)
+					(:else symb))
+				       )))
+				 )
+			    (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatfill=" e)
+			    e
+			    )
 			  )
-		       (put_fields xcmatcher :loca_location sloc)
-		       (put_fields xexport :loca_location sloc)
-		       (debug "gcc_tree_code:macro2" " sloc=" sloc "; " "@fixed xcmatcher=" debug_more xcmatcher
-			      "\n.. xexport=" xexport)
-		       (let (
-			     (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
-			     (rexport (macroexpand_1 xexport env mexpander modctx))
-			     )
-			 (debug "gcc_tree_code:macro2" " rmatch=" rmatch
-				"\n.. rexport=" rexport)
-			 (return rmatch (tuple rexport))
-			 ))
-		     )
-		    ;; otherwise
-		    ( :else
-		      (warning_at sloc "MELT should define $1 for tree code of type $2 arity $3"
-				  treesymb typcod nargcod)
-		      )
+			 (xcmatcher
+			  (let ( (m
+				  `(defcmatcher ,treesymb
+				     (:tree tr)
+				     (:tree ,tupopervar)
+				     ,statesymb
+				     :doc ,xcmatchdoc
+				     ;; match-expander
+				     ,xmatexp
+				     ;; match-filler
+				     ,xmatfill
+				     ))
+				 )
+			    (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xcmatcher=" m)
+			    m))
+			 (xexport `(export_values ,treesymb))
+			 )
+		      (put_fields xcmatcher :loca_location sloc)
+		      (put_fields xexport :loca_location sloc)
+		      (debug "gcc_tree_code:macro2" " sloc=" sloc "; " "@fixed xcmatcher=" debug_more xcmatcher
+			     "\n.. xexport=" xexport)
+		      (let (
+			    (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
+			    (rexport (macroexpand_1 xexport env mexpander modctx))
+			    )
+			(debug "gcc_tree_code:macro2" " rmatch=" rmatch
+			       "\n.. rexport=" rexport)
+			(return rmatch (tuple rexport))
+			))
 		    )
+		   ;; otherwise
+		   ( :else
+		     (debug "gcc_tree_code:macro2 bad namev=" namev)
+		     (warning_at sloc "MELT should define $1 for tree code of type $2 arity $3"
+				 treesymb typcod nargcod)
+		     )
 		   )
-		 (error_at sloc "unexpected GCC_TREE_CODE for $1" namev)
-		 (return ()) ;;  temporarily, happens for non-handled cases
-		 )
-	       )
+		  )
+		(error_at sloc "unexpected GCC_TREE_CODE for $1" namev)
+		(return ()) ;;  temporarily, happens for non-handled cases
+		)
+	      )
       )
   ;; for testing, these are not defined in libmelt-ana-tree.melt
   (gcc_tree_code TREE_BINFO "tree_binfo" tcc_exceptional 0)
-  (gcc_tree_code INDIRECT_REF "indirect_ref" tcc_reference 1)
-  (gcc_tree_code TRUTH_ORIF_EXPR "truth_orif_expr" tcc_expression 2)
-  (gcc_tree_code WIDEN_SUM_EXPR "widen_sum_expr" tcc_binary 2)
+  ;;! (gcc_tree_code INDIRECT_REF "indirect_ref" tcc_reference 1)
+  ;;! (gcc_tree_code TRUTH_ORIF_EXPR "truth_orif_expr" tcc_expression 2)
+  ;;! (gcc_tree_code WIDEN_SUM_EXPR "widen_sum_expr" tcc_binary 2)
   
   #|
   (debug "before loading2 libmelt-treecode")