2010-07-10 Basile Starynkevitch <basile@starynkevitch.net>

	{{tbad-3.melt correctly failing}}
	* gcc/melt/warmelt-base.melt: Added string!=
	* gcc/melt/warmelt-macro.melt: Added check in mexpand_defclass to
	catch redefinition of fields!
	* gcc/testsuite/melt/tbad-3.melt: Typo.



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

4 files changed, 42 insertions, 3 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 5eaace3e85b..15904f06cfb 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,6 +1,14 @@
 
 2010-07-10  Basile Starynkevitch  <basile@starynkevitch.net>
-	{{added tbad-3.melt which should fail bud don't}}
+	{{tbad-3.melt correctly failing}}
+	* melt/warmelt-base.melt: Added string!=
+	* melt/warmelt-macro.melt: Added check in mexpand_defclass to
+	catch redefinition of fields!
+	* testsuite/melt/tbad-3.melt: Typo.
+
+
+2010-07-10  Basile Starynkevitch  <basile@starynkevitch.net>
+	{{added tbad-3.melt which should fail but don't}}
 	* testsuite/melt/tfullgc.melt: Updated comment.
 	* testsuite/melt/tbad-3.melt: New file.
 
diff --git a/gcc/melt/warmelt-base.melt b/gcc/melt/warmelt-base.melt
index ee20f919362..f97cae8aeaf 100644
--- a/gcc/melt/warmelt-base.melt
+++ b/gcc/melt/warmelt-base.melt
@@ -450,6 +450,11 @@ an integer $I if $I is greater than $N.}#
   #{melt_string_same(($s1), ($s2))}#)
 
 
+(defprimitive string!= (s1 s2) :long 
+  :doc #{Test that value strings $S1 and $S2 are not equal as strings.}#
+  #{!melt_string_same(($s1), ($s2))}#)
+
+
 (defprimitive split_string_space (dis :cstring cs) :value
   :doc #{Split a cstring $CS into a list of space separated strings of
 discriminant $DIS.}#
@@ -1056,6 +1061,7 @@ significant iff ENABLE_CHECKING.}# #{(melt_application_depth() <
  is_stringconst
  string_length
  string=
+ string!=
  split_string_space
  split_string_comma
  split_string_colon
diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt
index a031809c386..127eec80122 100644
--- a/gcc/melt/warmelt-macro.melt
+++ b/gcc/melt/warmelt-macro.melt
@@ -2589,9 +2589,34 @@ $LAMBDA macros. A function defined by $DEFUN has to be exported with $EXPORT_VAL
 	(messagenum_dbg "expdefclafldnam ix" ix)
 	(assert_msg "check fldnam" (is_a fldnam class_symbol))
 	(let ( (fldstr (unsafe_get_field :named_name fldnam)) 
+	       (fldprevbind (find_env env fldnam))
 	       )
 	  (if (mapstring_getstr fieldstrmap fldstr)
 	      (error_strv fieldsloc "duplicate field in DEFLCLASS"_ fldstr))
+	  (cond
+	   ( (null fldprevbind)
+	     (void)
+	     )
+	   ( (is_a fldprevbind class_field_binding)
+	     (debug_msg fldprevbind "mexpand_defclass fldprevbind !field")
+	     (error_strv fieldsloc "field name already defined in DEFCLASS"_ fldstr)
+	     )
+	   ( (is_a fldprevbind class_value_binding)
+	     (debug_msg fldprevbind "mexpand_defclass fldprevbind !value")
+	     (debug_msg symb "mexpand_defclass symb !value")
+	     (let ( (prevalue (get_field :vbind_value fldprevbind))
+		    )
+	       ;; this test avoids warnings when recompiling
+	       ;; warmelt-*.melt files
+	       (if (or (is_not_a prevalue class_field)
+		       (string!= (get_field :named_name (get_field :fld_ownclass prevalue))
+				 (get_field :named_name symb)))
+		   (warning_strv fieldsloc "field name already bound to a value in DEFCLASS"_ fldstr)
+		 )))
+	   (:else
+	    (debug_msg fldprevbind "mexpand_defclass fldprevbind !other")
+	    (warning_strv  fieldsloc "field name previously bound in DEFCLASS"_ fldstr))
+	   )
 	  (let ( (:long fldoff (+i ix (get_int boxnbsuperfields))) 
 		 (newfld (instance class_field
 				   :named_name fldstr
@@ -2614,7 +2639,7 @@ $LAMBDA macros. A function defined by $DEFUN has to be exported with $EXPORT_VAL
 			:class_fields fieldtup)
      ;; we need to put the object magic to MELTOBMAG_OBJECT now
      (code_chunk setobjmagic
-		 #{((meltobject_ptr_t)$newclass)->obj_num = MELTOBMAG_OBJECT;
+		 #{((meltobject_ptr_t)$newclass)->obj_num = MELTOBMAG_OBJECT ;
 		 }#)
      (debug_msg newclass "mexp.defclass newclass" )
      (instance class_source_defclass
diff --git a/gcc/testsuite/melt/tbad-3.melt b/gcc/testsuite/melt/tbad-3.melt
index b357d23aa4e..dc4153be5f3 100644
--- a/gcc/testsuite/melt/tbad-3.melt
+++ b/gcc/testsuite/melt/tbad-3.melt
@@ -1,5 +1,5 @@
 ; -*- lisp -*-
-;; file tbad-2.melt
+;; file tbad-3.melt
 ;; this program should get a MELT error.
 
 #| run in buildir/gcc