2009-03-10 Basile Starynkevitch <basile@starynkevitch.net>

	[still a bug in compiling match; added tmatch-3.bysl test case;
	spurious check warnings in warmelt-first.bysl are resolved.]
	* gcc/melt/warmelt-first.bysl: added field mocx_initialenv to
	class_modulcontext.
	* gcc/melt/warmelt-normatch.bysl: removed compile_warning in
	normpat_jokerpat.
	* gcc/melt/warmelt-genobj.bysl: removed compile_warning in
	compilmatcher_cmatcher.
	* gcc/melt/warmelt-outobj.bysl: added generation of
	basilys_HAS_INITIAL_ENVIRONMENT and dirty trick in check
	putroutconst constnull to avoid spurious messages..
	* gcc/melt/ana-base.bysl: commented a match which does compile
	correctly.
	* gcc/testsuite/melt/tmatch-3.bysl: added new file exercising a bug.
	* gcc/testsuite/melt/tmallbuf.c: simplified the example.
	* gcc/warmelt-first-0.c: regenerated.
	* gcc/warmelt-macro-0.c: regenerated.
	* gcc/warmelt-normal-0.c: regenerated.
	* gcc/warmelt-normatch-0.c: regenerated.
	* gcc/warmelt-genobj-0.c: regenerated.
	* gcc/warmelt-outobj-0.c: regenerated.



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

2 files changed, 71 insertions, 5 deletions

diff --git a/gcc/testsuite/melt/tmallbuf.c b/gcc/testsuite/melt/tmallbuf.c
index 4376bbd3343..0386a075613 100644
--- a/gcc/testsuite/melt/tmallbuf.c
+++ b/gcc/testsuite/melt/tmallbuf.c
@@ -26,15 +26,14 @@ alloctab (int n)
 }
 
 int
-main (int argc, char **argv)
+main (void)
 {
+  int j;
   int k = 10;
   int *t = NULL;
-  if (argc > 1)
-    k = atoi (argv[1]);
-  if (k < 0)
-    k = 0;
   t = alloctab (k);
+  for (j=0; j<k; j+=2) 
+    t[j] *= 2;
   /* following instruction access t out of bounds */
   t[k + 1] = 2 * k;
   return 0;
diff --git a/gcc/testsuite/melt/tmatch-3.bysl b/gcc/testsuite/melt/tmatch-3.bysl
new file mode 100644
index 00000000000..99a22b9c6a7
--- /dev/null
+++ b/gcc/testsuite/melt/tmatch-3.bysl
@@ -0,0 +1,67 @@
+;; -*- lisp -*-
+;; file tmatch-3.bysl
+
+#| run in buildir/gcc
+ ./cc1 -fbasilys=translatefile -fbasilys-dynlibdir=. \
+    -fbasilys-compile-script=./built-melt-cc-script \
+    -fbasilys-gensrcdir=. -fbasilys-tempdir=/tmp -fbasilys-init=@warmelt2 \
+    -fbasilys-arg=..../tmatch-3.bysl -fbasilys-debug
+|#
+
+(defprimitive tree_content (v) :tree
+  "(basilys_tree_content((basilys_ptr_t)(" v ")))")
+
+;; pattern (tree_function_decl <funame>) match a tree for a function
+;; declaration
+(defcmatcher tree_function_decl 
+  (:tree tr) 				;matched
+  ;; output 
+  (:cstring funame
+   :tree initialdcl
+   )
+  treefun				;state symbol
+  (; test expansion
+   "((" tr ") && TREECODE(" tr ") == FUNCTION_DECL)"
+   )
+  (;; fill expansion
+   funame "=NULL; "
+   initialdcl "=NULL; "
+   "if (DECL_NAME(" tr ")) "
+   funame "= IDENTIFIER_POINTER(DECL_NAME(" tr ")); "
+   initialdcl  "=DECL_INITIAL(" tr "); "
+   )
+)
+
+;; similarily pattern (tree_variable_decl <funame>)
+(defcmatcher tree_variable_decl 
+  (:tree tr)
+  (:cstring varname
+   )
+  treevar
+  (; test expansion
+   "((" tr ") && TREECODE(" tr ") == VAR_DECL)"
+   )
+  (;; fill expansion
+   varname "=NULL; "
+   "if (DECL_NAME(" tr ")) "
+   varname "= IDENTIFIER_POINTER(DECL_NAME(" tr ")); ")
+)
+
+
+(defprimitive debugtree (:cstring msg :tree tr) :void
+  " do{debugeprintf(\"debugtree %s @%p\", " msg ", (void*)" tr ");"
+  "if (flag_basilys_debug) debug_tree(" tr ");}while(0) "
+)
+
+(defun tmatch_tree (declv)
+  (match 
+   (tree_content declv)
+   ( ?(tree_function_decl ?funam ?initree)
+      (debugtree "tmatchinitree" initree)
+      )
+   ( ?(tree_variable_decl ?varnam)
+      (put_fields scf :named_name (make_stringconst discr_string varnam))
+      )
+   ( ?_
+     () )
+   ))