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

	* gcc/testsuite/melt/tletrec.melt: added new file.
	* gcc/melt/warmelt-macro.melt: mexpand_letrec done...
	* gcc/melt/warmelt-normal.melt: added class_normal_constructor_binding
	class_normal_constructed_tuple_binding
	class_normal_constructed_pair_binding
	class_normal_constructed_list_binding
	class_normal_constructed_lambda_binding
	class_normal_constructed_instance_binding .... should add more for
	letrec...



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

4 files changed, 124 insertions, 21 deletions

diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 74864dae5f3..957ac4c5fc5 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,4 +1,14 @@
 2009-10-28  Basile Starynkevitch  <basile@starynkevitch.net>
+	* testsuite/melt/tletrec.melt: added new file.
+	* melt/warmelt-macro.melt: mexpand_letrec done...
+	* melt/warmelt-normal.melt: added class_normal_constructor_binding
+	class_normal_constructed_tuple_binding
+	class_normal_constructed_pair_binding
+	class_normal_constructed_list_binding
+	class_normal_constructed_lambda_binding
+	class_normal_constructed_instance_binding .... should add more for
+	letrec...
+2009-10-28  Basile Starynkevitch  <basile@starynkevitch.net>
 	[Begin adding letrec, tuple, list, constructs....]
 	* melt/warmelt-first.melt: added class_letrec_binding
 	* melt/warmelt-macro.melt: renamed class_sourcepattern* as
diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt
index d358b8a98ac..78a261a161c 100644
--- a/gcc/melt/warmelt-macro.melt
+++ b/gcc/melt/warmelt-macro.melt
@@ -4106,6 +4106,7 @@ expression context.  See also $INSTANCE and $DEFCLASS.}# )
 	      (foreach_in_multiple
 	       (recbindtup)
 	       (curbindexpr :long bindix)
+	       (debug_msg curbindexpr "mexpand_letrec firstloop curbindexpr")
 	       (if (is_not_a curbindexpr class_sexpr)
 		   ;; error message already given
 		   (return))
@@ -4138,18 +4139,22 @@ expression context.  See also $INSTANCE and $DEFCLASS.}# )
 		 (if (pair_tail curpair)
 		     (error_plain curloc "invalid LETREC binding - more than two components"))
 		 ))
+	      (debug_msg recsexprtup "mexpand_letrec recsexprtup after firstloop")
+	      (debug_msg vartup "mexpand_letrec vartup after firstloop")
+;;;
 	      ;; second loop to fill the newenv with empty letrec bindings
 	      (let ( (envmap (get_field :env_bind newenv)) ;; to ensure no repeated variable in letrec
 		     )
 		(foreach_in_multiple
 		 (vartup)
 		 (curvar :long varix)
+		 (debug_msg curvar "mexpand_letrec second loop curvar")
 		 (if (mapobject_get envmap curvar)
 		     (error_strv loc "repeated variable in LETREC binding"
 				 (get_field :named_name curvar)))
 ;;; make the binding
 		 (let ( (curbind (instance class_letrec_binding
-					   :binder vartup
+					   :binder curvar
 					   :letbind_type ctype_value
 					   :letbind_expr () ;filled later
 					   )) 
@@ -4157,6 +4162,8 @@ expression context.  See also $INSTANCE and $DEFCLASS.}# )
 		   (put_env newenv curbind)
 		   (multiple_put_nth bindtup varix curbind)
 		   )))
+	      (debug_msg bindtup "mexpand_letrec bindtup after secondloop")
+;;;
 	      ;; third loop to expand the bound expressions which should be recursively constructible
 	      (foreach_in_multiple
 	       (recsexprtup)
@@ -4172,13 +4179,23 @@ expression context.  See also $INSTANCE and $DEFCLASS.}# )
 		       (return)))
 		 (put_fields curbind :letbind_expr curexp)
 		 (multiple_put_nth exprtup expix curexp)
-		 ))
+		 (let ( (sbind
+			 (instance class_source_letrec_binding
+				   :loca_location (or (get_field :loca_location curexp) loc)
+				   :sletb_type ctype_value
+				   :sletb_binder (multiple_nth vartup expix)
+				   :sletb_expr curexp
+				   )
+			 ) )
+		   (multiple_put_nth srcbindtup expix sbind)
+		   )))
+	      (debug_msg exprtup "mexpand_letrec exprtup after thirdloop")
 	      )		;end let recbindtup when bindexpr is an s-expr
 	  (error_plain loc "missing letbinding-s in LETREC"_))
       )
+    (debug_msg srcbindtup "mexpand_letrec srcbindtup")
     (setq bodytup (pairlist_to_multiple restpair discr_multiple 
 					(lambda (e) (macroexpand_1 e newenv mexpander))))
-    (compile_warning "should fill the srcbindtup")
     (let ( (letr
 	    (instance class_source_letrec
 		      :loca_location loc
diff --git a/gcc/melt/warmelt-normal.melt b/gcc/melt/warmelt-normal.melt
index 264821bb821..59ea882adf1 100644
--- a/gcc/melt/warmelt-normal.melt
+++ b/gcc/melt/warmelt-normal.melt
@@ -236,6 +236,52 @@
 	   ;;;; see file warmelt-normatch.melt
 ))
 
+;;;;;;;;;;;;;;;;
+(defclass class_normal_constructor_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTOR_BINDING is the common
+super-class of constructor bindings in LETREC... Field $NCONSB_LOC
+gives the optional location, and field $NCONSB_DISCR gives the normalized discriminant.}#
+  :super class_any_binding
+  :fields (nconsb_loc nconsb_discr)
+)
+
+(defclass class_normal_constructed_tuple_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_TUPLE_BINDING is the
+class of tuple constructor bindings. Field $NTUPB_COMP gives the tuple
+of initial normalized components.}#
+  :super class_normal_constructor_binding
+  :fields (ntupb_comp))
+
+(defclass class_normal_constructed_pair_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_PAIR_BINDING is the
+  class of pair constructor bindings. Field $NPAIRB_HEAD gives the
+  normalized head, and $NPAIRB_TAIL gives the normalized tail.}#
+  :super class_normal_constructor_binding
+  :fields (npairb_head npairb_tail))
+
+(defclass class_normal_constructed_list_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LIST_BINDING is the
+class of list constructor bindings. Field $NLISTB_FIRST gives the
+initial normalized first pair, and field $NLISTB_LAST gives the last
+one.}#
+  :super  class_normal_constructor_binding
+  :fields (nlistb_first nlistb_last))
+
+(compile_warning "think about class_normal_constructed_lambda_binding")
+(defclass class_normal_constructed_lambda_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LAMBDA_BINDING is the
+class of lambda constructor bindings. Field $NLAMBDAB_ ....}#
+  :super  class_normal_constructor_binding
+  :fields (nlambdab_))
+
+(defclass class_normal_constructed_instance_binding
+  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_INSTANCE_BINDING is
+the class of instance constructor bindings. Field $NINSTB_SLOTS is the
+tuple of the normalized slots.}#
+  :super  class_normal_constructor_binding
+  :fields (ninstb_slots))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; procedures
 (defclass class_nrep_anyproc
   :super class_nrep
@@ -463,6 +509,12 @@
 
 ;;; export all the normalized representations classes
 (export_class ;; normal representations classes in alphabetical order
+ class_normal_constructor_binding
+ class_normal_constructed_tuple_binding
+ class_normal_constructed_pair_binding
+ class_normal_constructed_list_binding
+ class_normal_constructed_lambda_binding
+ class_normal_constructed_instance_binding
  class_nrep
  class_nrep_anyproc
  class_nrep_apply
@@ -3122,29 +3174,23 @@
   (assert_msg "check nctxt" (is_a ncx class_normalization_context))
   (debug_msg recv "normexp_tuple recv")
   (let ( (sloc (unsafe_get_field :loca_location recv))
+	 (sargs (unsafe_get_field :sargop_args recv))
 	 )
-    (compile_warning "normexp_tuple incomplete")
-    (error_plain sloc "unimplemented TUPLE normalization")
-    (assert_msg "@$@unimplemented TUPLE" ())
-    ))
+    (multicall
+     (nargs nbindings)
+     (normalize_tuple sargs env ncx sloc)
+     (debug_msg nargs "normexp_tuple nargs")
+     (debug_msg nbindings "normexp_tuple nbindings")
+     ;; insght: normalize (tuple x1 x2) exactly as 
+     ;; as an anonymous letrec
+     (compile_warning "normexp_tuple incomplete")
+     (error_plain sloc "unimplemented TUPLE normalization")
+     (assert_msg "@$@unimplemented TUPLE" ())
+     )))
 (install_method class_source_tuple normal_exp normexp_tuple)
 
 ;;;;;;;;;;;;;;;;
 
-(defun normexp_tuple (recv env ncx psloc)
-  (assert_msg "check tuple recv" (is_a recv class_source_tuple))
-  (assert_msg "check env" (is_a env class_environment))
-  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
-  (debug_msg recv "normexp_tuple recv")
-  (let ( (sloc (unsafe_get_field :loca_location recv))
-	 )
-    (compile_warning "normexp_tuple incomplete")
-    (error_plain sloc "unimplemented TUPLE normalization")
-    (assert_msg "@$@unimplemented TUPLE" ())
-    ))
-(install_method class_source_tuple normal_exp normexp_tuple)
-
-;;;;;;;;;;;;;;;;
 
 (defun normexp_list (recv env ncx psloc)
   (assert_msg "check list recv" (is_a recv class_source_list))
@@ -3152,6 +3198,7 @@
   (assert_msg "check nctxt" (is_a ncx class_normalization_context))
   (debug_msg recv "normexp_list recv")
   (let ( (sloc (unsafe_get_field :loca_location recv))
+	 (sargs (unsafe_get_field :sargop_args recv))
 	 )
     (compile_warning "normexp_list incomplete")
     (error_plain sloc "unimplemented LIST normalization")
diff --git a/gcc/testsuite/melt/tletrec.melt b/gcc/testsuite/melt/tletrec.melt
new file mode 100644
index 00000000000..6638cf2ee73
--- /dev/null
+++ b/gcc/testsuite/melt/tletrec.melt
@@ -0,0 +1,29 @@
+; -*- lisp -*-
+;; file tletrec.melt
+
+#| run in buildir/gcc
+ ./cc1 -fmelt=runfile  -fmelt-module-path=.    -fmelt-source-path=.:$GCCMELTSOURCE/gcc/melt \
+    -fmelt-compile-script=./built-melt-cc-script \
+    -fmelt-tempdir=/tmp -fmelt-init=@warmelt2 \
+    -fmelt-arg=$GCCMELTSOURCE/gcc/testsuite/melt/tletrec.melt -fmelt-debug empty-file-for-melt.c
+|#
+
+(defun testletrec (u :long j)
+  (letrec (
+	   (fa (lambda (x :long n)
+		 (debug_msg x "x inside fa")
+		 (if (<i n 0) x (fb x (-i n 1)))))
+	   (fb (lambda (y :long p) 
+		 (debug_msg y "y inside fb")
+		 (if (<=i p 0) 
+		     (make_tuple2 discr_multiple y tu)
+		     (fa y (/i p 2)))))
+	   (tu (tuple ii 'zz ll))
+	   (ll (list ii '2))
+	   (ii (instance class_container 
+			 :container_value ll))
+	   )
+	  (fa u j)
+	  ))
+       
+;; eof tletrec.melt
\ No newline at end of file