2008-04-04 Basile Starynkevitch <basile@starynkevitch.net>

	[tried warm bootstrap which is still buggy]

	* gcc/melt/warm-basilys.bysl: various tiny bugfixes.
	(scan_defclass) handles correctly :obj_num or :predef.
	(parse_field_assignment) cla can be null.
	(wrap_normal_let1, compilobj_dataroutine) removed debugging backtraces.

	* gcc/basilys.h: basilys_list_length (nil) is 0.
	* gcc/basilys.c: (basilys_list_length) likewise.



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

5 files changed, 21 insertions, 12 deletions

diff --git a/gcc/ChangeLog.melt b/gcc/ChangeLog.melt
index 4f9ef8e368b..6e83c92b5e8 100644
--- a/gcc/ChangeLog.melt
+++ b/gcc/ChangeLog.melt
@@ -1,3 +1,14 @@
+2008-04-04   Basile Starynkevitch  <basile@starynkevitch.net>
+	[tried warm bootstrap which is still buggy]
+
+	* melt/warm-basilys.bysl: various tiny bugfixes.
+	(scan_defclass) handles correctly :obj_num or :predef.
+	(parse_field_assignment) cla can be null.
+	(wrap_normal_let1, compilobj_dataroutine) removed debugging backtraces.
+
+	* basilys.h: basilys_list_length (nil) is 0.
+	* basilys.c: (basilys_list_length) likewise.
+
 2008-04-02   Basile Starynkevitch  <basile@starynkevitch.net>
 	* melt/warm-basilys.bysl: multiresult apply & send outpucod not tested.
 
diff --git a/gcc/basilys.c b/gcc/basilys.c
index b6ed0946b9e..b837ce18978 100644
--- a/gcc/basilys.c
+++ b/gcc/basilys.c
@@ -2609,6 +2609,8 @@ basilys_list_length (basilys_ptr_t list_p)
 {
   struct basilyspair_st *pair = NULL;
   int ln = 0;
+  if (!list_p) 
+    return 0;
   if (basilys_magic_discr (list_p) != OBMAG_LIST)
     return -1;
   for (pair = ((struct basilyslist_st *) list_p)->first;
diff --git a/gcc/basilys.h b/gcc/basilys.h
index a4e75a8f53b..0d214544c10 100644
--- a/gcc/basilys.h
+++ b/gcc/basilys.h
@@ -1343,7 +1343,7 @@ void basilysgc_prepend_list (basilys_ptr_t list_p, basilys_ptr_t val_p);
 /* pop from head of list (and remove) */
 basilys_ptr_t basilysgc_popfirst_list (basilys_ptr_t list_p);
 
-/* return the length of a list or -1 iff non list */
+/* return the length of a list, 0 for nil, or -1 iff non list */
 int basilys_list_length (basilys_ptr_t list_p);
 
 /* allocate e new empty mapobjects */
diff --git a/gcc/melt/test1.bysl b/gcc/melt/test1.bysl
index 1d9ce0d6699..6ec59626610 100644
--- a/gcc/melt/test1.bysl
+++ b/gcc/melt/test1.bysl
@@ -106,12 +106,9 @@
 (let ((kk (mkint_t2 5))) (if (tup1_pr2 kk my_class_root) (mkint_t2 0)))
 
 
-(defun hello_t2 (f) (f "hello"))
 
 (defun n1234_t2 (f) (f 1234))
 
-(defun xhello_t2 (f x) (f x x "hellox"))
-
 (defun xn12345_t2 (f x) (f x x 12345))
 
 
diff --git a/gcc/melt/warm-basilys.bysl b/gcc/melt/warm-basilys.bysl
index 342b730e14a..1d3b80bf7b9 100644
--- a/gcc/melt/warm-basilys.bysl
+++ b/gcc/melt/warm-basilys.bysl
@@ -2668,8 +2668,9 @@
 			   ))
 		       ( (== curkw ':fields)
 			 (if fieldnams (error_plain loc "duplicate fields in defclass"))
-			 (if (not (is_a curval class_sexpr))
-			     (error_plain loc "bad fields in defclass"))
+			 (and curval
+			      (not (is_a curval class_sexpr))
+			      (error_plain loc "bad fields in defclass"))
 			 (let ( (namlist (unsafe_get_field :sexp_contents curval))
 				(namloc (unsafe_get_field :loca_location curval))
 				(:long nbnam  (list_length namlist))
@@ -2828,9 +2829,9 @@
 
 ;;;;;;;;;;;;;;;; the definstance expander
 
-;; internal to parse a field assignment in a given class
+;; internal to parse a field assignment in a given class (or without class, for put_field)
 (defun parse_field_assignment (cla loc fldkw expr env mexpander)
-  (assert_msg "check cla" (is_a cla class_class))
+  (debug_msg "parse_field_assignment cla" cla (the_callcount))
   (assert_msg "check fldkw" (is_a fldkw class_keyword))
   (assert_msg "check env" (is_a env class_environment))
   (assert_msg "check mexpander" (is_closure mexpander))
@@ -2928,14 +2929,14 @@
 		   (setq curpair (pair_tail curpair))
 		   (let ( (curexp (pair_head curpair)) )
 		     (cond  ( (== curfkw ':obj_num)
-			      (if curexp (error_plain loc "duplicate :obj_num in definstance"))
+			      (if objnum (error_plain loc "duplicate :obj_num in definstance"))
 			      (setq objnum 
 				    (if (is_a curexp class_sexpr)
 					(macroexpand_1 curexp env mexpander)
 				      curexp))
 			      )
 			    ( (== curfkw ':predef)
-			      (if curexp (error_plain loc "duplicate :predef in definstance"))
+			      (if predef (error_plain loc "duplicate :predef in definstance"))
 			      (setq predef 
 				    (if (is_a curexp class_sexpr)
 					(macroexpand_1 curexp env mexpander)
@@ -4167,7 +4168,6 @@
    bindlist 
    (lambda (cbind) 
      (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normlet_binding))))
-  (or nexp (shortbacktrace_dbg "wrap_normal_let1 null nexp" 15))
   (if 
       (and (is_list bindlist)
 	   (is_pair (list_first bindlist)))
@@ -10036,7 +10036,6 @@
   (assert_msg "check gcx" (is_a gcx class_genercontext))
   (debug_msg "compilobj_dataroutine+ gcx" gcx (the_callcount))
   (debug_msg "compilobj_dataroutine+ ndrou" ndrou (the_callcount))
-  (shortbacktrace_dbg "compilobj_dataroutine+" 12)
   (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
 	 (inirout (unsafe_get_field :gncx_objrout gcx))
 	 (chobj (mapobject_get compicache ndrou))