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

	* melt/warmelt-macro.melt (lambda_arg_bindings): More debug.



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

1 files changed, 22 insertions, 3 deletions

diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt
index 6eead1ed22f..2c4712081ff 100644
--- a/gcc/melt/warmelt-macro.melt
+++ b/gcc/melt/warmelt-macro.melt
@@ -2688,6 +2688,8 @@ the object-map for pattern variables. $PCTX_MODCTX is the module context.}#
 ;;; usually argmode is just missing
 ;;; TODO: perhaps consider a :macro argmode also??
 (defun lambda_arg_bindings (formalsexp argmode env mexpander modctx)
+  (debug "lambda_arg_bindings" " start formalsexp=" formalsexp
+	 "\n.. argmode=" argmode " env=" debug_less env)
   ;; special case for null arglist
   (when (null formalsexp)
     (return (make_multiple discr_formal_sequence 0)))
@@ -2696,17 +2698,29 @@ the object-map for pattern variables. $PCTX_MODCTX is the module context.}#
 	 (argtype ctype_value)
 	 (rawarglist (unsafe_get_field :sexp_contents formalsexp))
 	 (argloc (unsafe_get_field :loca_location formalsexp))
-	 (arglist (expand_pairlist_as_list (list_first rawarglist) env mexpander modctx))
+	 (arglist
+	  (progn
+	    (debug "lambda_arg_bindings" " argloc=" argloc "; rawarglist=" rawarglist)
+	    (let
+		( (al
+		   (expand_pairlist_as_list (list_first rawarglist) env mexpander modctx))
+		  )
+	      (debug "lambda_arg_bindings" " argloc=" argloc "; arglist=" al)
+	      al
+	      )))
 	 (argmap (make_mapobject discr_map_objects (+i 4 (list_length arglist))))
 	 (bndlist (make_list discr_list)) 
 	 (curpair (list_first arglist))
 	 (tupdis discr_formal_sequence)
 	 )
+    (debug "lambda_arg_bindings" " argloc=" argloc "; arglist=" arglist)
     ;; first loop on arg
     (forever argloop
 	     (if (null curpair) (exit argloop))
 	     (assert_msg "check curpair" (is_pair curpair) curpair)
 	     (let ( (curarg (pair_head curpair)) )
+	       (debug "lambda_arg_bindings" " argloc=" argloc
+		      "; curarg=" curarg)
 	       (cond
 		( (== curarg :rest)
 		  (setq curpair (pair_tail curpair))
@@ -2725,6 +2739,8 @@ the object-map for pattern variables. $PCTX_MODCTX is the module context.}#
 		  (let ( (cty (unsafe_get_field :symb_data curarg)) 
 			 (curargname (unsafe_get_field :named_name curarg))
 			 )
+		    (debug "lambda_arg_bindings" " argloc=" argloc
+			   " keyword curarg=" curarg)
 		    (cond 
 		     ( (is_not_a cty class_ctype)
 		       (error_at argloc "non-ctype keyword $1 in formal arglist"_
@@ -2803,7 +2819,7 @@ the object-map for pattern variables. $PCTX_MODCTX is the module context.}#
 	       (setq ix (+i ix 1))
 	       (setq bndpair (pair_tail bndpair))
 	       )
-      (debug "lambda_arg_bindings result bndtup" bndtup)
+      (debug "lambda_arg_bindings" " argloc=" argloc "; result bndtup" bndtup)
       (return bndtup)
       )))
 
@@ -2989,7 +3005,10 @@ the object-map for pattern variables. $PCTX_MODCTX is the module context.}#
       (error_at () "MELT has invalid macro translating running macroexpansions function - corruption")
       (return))
     (when (>i (melt_error_counter) 0)
-      (error_at () "MELT won't translate running macroexpansions since got errors")
+      (error_at () "MELT won't translate running macroexpansions since got $1 errors" (melt_error_counter))
+      (if (>i (melt_error_counter) 15)
+	  (fatal_error_at () "MELT got too many $1 errors in macroexpansions" (melt_error_counter))
+	  )
       (return))
     (debug "melt_invoke_translator_runner_macroexpansions melt_transrunmacro_clos=" clos
 	   "\n... env=" debug_less env "\n... modctx=" debug_less modctx)