2013-10-25 Basile Starynkevitch <basile@starynkevitch.net>

	* melt/warmelt-genobj.melt (compile2obj_initextendproc)
	(compilobj_nrep_locsymocc): More debug.

	* melt/warmelt-outobj.melt (autobox_normal_return): More
	debug. Perhaps should create another binding for the
	class_nrep_return instance....
	(translate_run_melt_expressions): More debug.

	* melt/warmelt-modes.melt (eval_docmd, evalfile_docmd): More
	debug, and describe the created environments.



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

4 files changed, 50 insertions, 21 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 8dea2329b49..49cb2bbe6e1 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,5 +1,17 @@
 
 2013-10-25  Basile Starynkevitch  <basile@starynkevitch.net>
+	* melt/warmelt-genobj.melt (compile2obj_initextendproc)
+	(compilobj_nrep_locsymocc): More debug.
+
+	* melt/warmelt-outobj.melt (autobox_normal_return): More
+	debug. Perhaps should create another binding for the
+	class_nrep_return instance....
+	(translate_run_melt_expressions): More debug.
+
+	* melt/warmelt-modes.melt (eval_docmd, evalfile_docmd): More
+	debug, and describe the created environments.
+
+2013-10-25  Basile Starynkevitch  <basile@starynkevitch.net>
 	* melt/warmelt-outobj.melt (translate_run_melt_expressions): If
 	the run-infix program argument is given as
 	-fplugin-arg-melt-run-infix=FOO use it instead of the process id
diff --git a/gcc/melt/warmelt-genobj.melt b/gcc/melt/warmelt-genobj.melt
index c8406b603b6..749ada7dae1 100644
--- a/gcc/melt/warmelt-genobj.melt
+++ b/gcc/melt/warmelt-genobj.melt
@@ -2059,7 +2059,8 @@
 			      ))
        (debug "compile2obj_initextendproc before body oiniprolog=" oiniprolog
 	      "\n idata=" idata)
-       (debug "compile2obj_initextendproc again toplis=" toplis)
+       (debug "compile2obj_initextendproc again toplis=" toplis
+	      "\n.. gcx=" debug_less gcx)
        (assert_msg "check toplis" (is_list_or_null toplis) toplis)
        ;; compile the toplevels
        (let ( (objtoplis 
@@ -2504,7 +2505,7 @@
 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun compilobj_nrep_locsymocc (lsyo gcx)
-   (debug "compilobj locsymocc begin lsyo=" lsyo)
+   (debug "compilobj_nrep_locsymocc begin lsyo=" lsyo)
    (assert_msg "check nchk" (is_a lsyo class_nrep_locsymocc) lsyo)
    (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
    (let ( (loc (unsafe_get_field :nrep_loc lsyo))
@@ -2514,18 +2515,21 @@
 	  (sbnd (unsafe_get_field :nocc_bind lsyo))
 	  (ovar (mapobject_get locmap sbnd))
 	  )
-     (debug "compilobj locsymocc sbnd=" sbnd " ovar=" ovar)
+     (debug "compilobj_nrep_locsymocc sbnd=" sbnd " ovar=" ovar)
      (when (null sbnd)
        (debug "compilobj_nrep_locsymocc null sbnd lsyo=" lsyo " sym=" sym)
        (assert_msg "locsymocc without binding" () lsyo)
 	   )
      (if (null ovar) 
 	 (progn
-	   (debug "compilobj locsymocc null ovar sbnd=" sbnd " locmap=" locmap " lsyo=" lsyo)
-	   (assert_msg "compilobj locsymocc null ovar without ctype_void" (== oty ctype_void) oty lsyo)
+	   (debug "compilobj locsymocc null ovar sbnd=" sbnd 
+		  "\n.. locmap=" locmap 
+		  "\n.. lsyo=" lsyo 
+		  "\n.. gcx=" debug_less gcx)
+	   (assert_msg "compilobj_nrep_locsymocc null ovar without ctype_void" (== oty ctype_void) oty lsyo locmap)
 	   )
-       (assert_msg "compilobj locsymocc check ovar"  (is_a ovar class_objlocv) ovar))
-     (debug "compilobj locsymocc end lsyo=" lsyo " gives ovar=" ovar)
+       (assert_msg "compilobj_nrep_locsymocc check ovar"  (is_a ovar class_objlocv) ovar))
+     (debug "compilobj_nrep_locsymocc end lsyo=" lsyo " gives ovar=" ovar)
      (return ovar)
      ))
  (install_method class_nrep_locsymocc compile_obj compilobj_nrep_locsymocc)
diff --git a/gcc/melt/warmelt-modes.melt b/gcc/melt/warmelt-modes.melt
index 1907f5b31a4..3b74cfc7dea 100644
--- a/gcc/melt/warmelt-modes.melt
+++ b/gcc/melt/warmelt-modes.melt
@@ -197,7 +197,10 @@ has basic debug support thru DEBUG, ASSERT_MSG..."
     (assert_msg "check curenv" (is_a curenv class_environment) curenv)
     (let (
 	  (:long nbexprs (list_length inexprs))
-	  (newenv (fresh_env curenv))
+	  (newenv (let ( (ne (fresh_env curenv 'eval-mode inarg))
+			 )
+		    (debug "eval_docmd newenv=" ne)
+		    ne))
 	  (res (translate_run_melt_expressions inexprs newenv))
 	  (dbgi (instance class_debug_output_information
 			  :dbgi_out stdout
@@ -247,7 +250,10 @@ has basic debug support thru DEBUG, ASSERT_MSG..."
     (assert_msg "check curenv" (is_a curenv class_environment) curenv)
     (let (
 	  (:long nbexprs (list_length inexprs))
-	  (newenv (fresh_env curenv))
+	  (newenv (let ( (ne (fresh_env curenv (tuple 'eval-file inarg)))
+			 )
+		    (debug "evalfile_docmd newenv=" ne)
+		    ne))
 	  (res (translate_run_melt_expressions inexprs newenv))
 	  (dbgi (instance class_debug_output_information
 			  :dbgi_out stdout
diff --git a/gcc/melt/warmelt-outobj.melt b/gcc/melt/warmelt-outobj.melt
index 7867b6f7be8..2ebd0e41291 100644
--- a/gcc/melt/warmelt-outobj.melt
+++ b/gcc/melt/warmelt-outobj.melt
@@ -7063,7 +7063,7 @@ if (1) return;
 ;; utility function to box a non-value normal as a return of an
 ;; autoboxed value
 (defun autobox_normal_return (nexp ctyp ncx)
-  (debug "autobox_normal_return nexp=" nexp " ctyp=" ctyp " ncx=" ncx)
+  (debug "autobox_normal_return nexp=" nexp " ctyp=" ctyp " ncx=" debug_less ncx)
   (shortbacktrace_dbg "autobox_normal_return" 12)
   (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp)
   (let ( (csym (clone_symbol 'retautoboxval))
@@ -7078,17 +7078,19 @@ if (1) return;
 			  :nocc_ctyp ctype_value
 			  :nocc_symb csym
 			  :nocc_bind cbind))
-	 (nbinds (list))
+	 (nbinds (list cbind))
 	 )
-    (debug "autobox_normal_return clocc=" clocc " incomplete cbind=" cbind)
+    (debug "autobox_normal_return clocc=" clocc " incomplete cbind=" cbind
+	   "\n.. nbinds=" nbinds)
     (cond
      ( (== ctyp ctype_value)
        (if (is_not_a nexp class_nrep_return)
 	   (let ( (nret (instance class_nrep_return
-				  :nret_main nexp
+				  :nret_main clocc
 				  ))
 		  )
-	     (debug "autobox_normal_return gives nret=" nret " nbinds=" nbinds)
+	     (put_fields cbind :letbind_expr nexp)
+	     (debug "autobox_normal_return gives nret=" nret " nbinds=" nbinds "\n cbind=" cbind)
 	     (return nret nbinds))
 	 (return nexp nbinds)))
      ;; autoboxing longs
@@ -7112,7 +7114,6 @@ if (1) return;
 			      ))
 	      )
 	 (put_fields cbind :letbind_expr nchk)
-	 (list_append nbinds cbind)
 	 (debug "autobox_normal_return long return nret=" nret " nbinds=" nbinds)
 	 (return nret nbinds)
 	 ))
@@ -7124,7 +7125,6 @@ if (1) return;
 			      :nret_main clocc))
 	      )
 	 (put_fields cbind :letbind_expr nilr)
-	 (list_append nbinds cbind)
 	 (debug "autobox_normal_return void return nret=" nret " nbinds=" nbinds)
 	 (return nret nbinds)		    
        ))
@@ -7149,7 +7149,6 @@ if (1) return;
 			      ))
 	      )
 	 (put_fields cbind :letbind_expr nchk)
-	 (list_append nbinds cbind)
 	 (debug "autobox_normal_return cstring return nret=" nret " nbinds=" nbinds)
 	 (return nret nbinds)
 	 ))
@@ -7189,7 +7188,6 @@ if (1) return;
 			      ))
 	      )
 	 (put_fields cbind :letbind_expr nchk)
-	 (list_append nbinds cbind)
 	 (debug "autobox_normal_return gtyctype return nret=" nret " nbinds=" nbinds)
 	 (return nret nbinds)
 	 ))
@@ -7291,7 +7289,7 @@ if (1) return;
 	     (debug "translate_run_melt_expressions macroenv=" debug_more menv)
 	     menv))
 	  (modctx
-	   (instance class_running_extension_module_context
+	   (let ( (m (instance class_running_extension_module_context
 		     :mocx_modulename  nakedbasnam
 		     :mocx_expfieldict (make_mapstring discr_map_strings 71)
 		     :mocx_expclassdict (make_mapstring discr_map_strings 19)
@@ -7314,6 +7312,9 @@ if (1) return;
 		     :morcx_countlitval (make_integerbox discr_integer 1)
 		     :morcx_literobjmap (make_mapobject discr_map_objects 53)
 		     ))
+		  )
+	     (debug "translate_run_melt_expressions modctx=" m)
+	     m))
 	  (ncx 
 	   (create_normal_extending_context modctx env))
 	  (lsexp
@@ -7379,7 +7380,10 @@ if (1) return;
 	(runerrorhdlr '"runtime invalid expressions")
 	(return () ()))
       (let ( (xlist
-	      (macroexpand_toplevel_list lsexp env macroexpand_1 modctx)) 
+	      (let ( (xl (macroexpand_toplevel_list lsexp env macroexpand_1 modctx))
+		     )
+		(debug "translate_run_melt_expressions xlist=" xl)
+		xl))
 	     (:long lenxlist (list_length xlist))
 	     ;; normalextend should ensure that the last normal gives a value
 	     (normalextend 
@@ -7390,7 +7394,10 @@ if (1) return;
 		(shortbacktrace_dbg "translate_run_melt_expressions/normalextend" 13)
 		(assert_msg "check null !refnormlist" (null !refnormlist) refnormlist)
 		(let ( (lastnormpair (list_last normlist))
-		       (lastnorm (list_last_element normlist))
+		       (lastnorm (let ( (ln (list_last_element normlist))
+					)
+				   (debug "translate_run_melt_expressions/normalextend lastnorm=" ln)
+				   ln))
 		       (lastctyp (get_ctype lastnorm inienv))
 		       )
 		  (debug "translate_run_melt_expressions/normalextend lastnorm=" lastnorm