2008-06-21 Basile Starynkevitch <basile@starynkevitch.net>

	* Makefile.in: added warmelt-normal.c & warmelt-genobj.c targets.
	splitting warm-basilys.bysl in consecutive chunks.

	* melt/warm-basilys.bysl: defprimitive does fill the type in the
	data. reorganized order of definitions to facilitate splitting.



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

1 files changed, 484 insertions, 428 deletions

diff --git a/gcc/melt/warm-basilys.bysl b/gcc/melt/warm-basilys.bysl
index fd628088341..8c621cd7fe5 100644
--- a/gcc/melt/warm-basilys.bysl
+++ b/gcc/melt/warm-basilys.bysl
@@ -31,10 +31,10 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-;;;;; lines starting with ;;<< are handled by an awk script to split
+;;;;; lines starting with ;;@@<< are handled by an awk script to split
 ;;;;; this into several files
 
-;;<< warmelt-first.bysl
+;;@@<< warmelt-first.bysl
 
 ;;****************************************************************
 ;;       C L A S S E S 
@@ -2994,11 +2994,10 @@
 (export_values
   put_env
   list_map)
-;;>> warmelt-first.bysl
 
 ;;****************************************************************
 
-;;<< warmelt-macro.bysl
+;;@@<< warmelt-macro.bysl
 
 ;;; source application 
 (defclass class_src_apply
@@ -3007,10 +3006,12 @@
 	   sapp_args			;the arguments tuple
 	   ))
 
+
 ;;; source message sending 
 (defclass class_src_msend
   :super class_src
   :fields ( 
+;; the selector binding is needed to get its data...
 	    msend_selbind		;the selector binding
 	    msend_recv			;the reciever
 	    msend_args 			;the tuple of arguments
@@ -3413,6 +3414,7 @@
   (assert_msg "check mexpander" (is_closure mexpander))
   (if (is_a sexpr class_sexpr)
       (let ( (scont (unsafe_get_field :sexp_contents sexpr))
+	     (sloc (unsafe_get_field :loca_location sexpr))
 	     (soper (pair_head (list_first scont))) )
 	(debug_msg sexpr "macroexpand_1 sexpr")
 	(debug_msg soper "macroexpand_1 soper")
@@ -3432,10 +3434,35 @@
 			    (return ress)
 			    ))
 			( (is_a opbind class_primitive_binding)
-			  (let ( (resp (expand_primitive opbind sexpr env mexpander)) )
+			  (let ( (resp (expand_primitive (unsafe_get_field :pbind_primitive opbind) sexpr env mexpander)) )
 			    (debug_msg resp "macroexpand_1 result for primitive resp")
 			    (return resp)
 			    ))
+			( (is_a opbind class_value_binding)
+			  (let ( (val (unsafe_get_field :vbind_value opbind))
+				 )
+			    (cond
+			     ( (is_closure val)
+			       (expand_apply sexpr env mexpander)
+			       )
+			     ( (is_a val class_primitive)
+			       (expand_primitive val sexpr env mexpander)
+			       )
+			     ( (is_a val class_selector)
+			       ;; voir expand_msend
+			       (compile_warning "macroexpand_1 a completer valeur selecteur")
+			       (error_strv sloc "macroexpand_1 val.sel @@ a completer"
+					   (unsafe_get_field :named_name (unsafe_get_field :binder opbind)))
+			       (assert_msg "macroexpand_1 val.sel @@ UNIMPLEMENTED " ())
+			       )
+			     (:else
+			      (error_strv sloc "macroexpand_1 bad valued operation symbol"
+					  (unsafe_get_field :named_name soper))
+			      (inform_strv sloc "macroexpand_1 bad symbol value discr"
+					   (unsafe_get_field :named_name (discrim val)))
+			      (return)
+			      )
+			     )))
 			(:else 
 			 ;; this is to catch the case when DEFUN or DEFCLASS is not bound...
 			 (assert_msg "check soper not symbol DEFUN" (!= soper 'defun))
@@ -3464,8 +3491,8 @@
     (return sexpr)))
   
 ;;; expand a primitive s-expression
-(defun expand_primitive (opbind sexpr env mexpander)
-  (assert_msg "check opbind" (is_a opbind class_primitive_binding))
+(defun expand_primitive (sprim sexpr env mexpander)
+  (assert_msg "check sprim" (is_a sprim class_primitive))
   (assert_msg "check sexpr" (is_a sexpr class_sexpr))
   (assert_msg "check end" (is_a env class_environment))
   (assert_msg "check mexpander" (is_closure mexpander))
@@ -3473,9 +3500,7 @@
 	 (sloc (unsafe_get_field :loca_location sexpr))
 	 (soper (pair_head (list_first scont)))
 	 (xargtup (expand_restlist_as_tuple scont env mexpander))
-	 (sprim (unsafe_get_field :pbind_primitive opbind))
 	 )
-    (assert_msg "check sprim" (is_a sprim class_primitive))
     (make_instance class_src_primitive
 		   :src_loc sloc
 		   :sprim_oper sprim
@@ -5050,10 +5075,6 @@
 	(xtest ())
 	(assfail_binding (find_env env 'assert_failed))
 	)
-    (if (is_not_a assfail_binding class_primitive_binding)
-	(progn
-	  (error_plain loc "ASSERT_FAILED not bound to a primitive in  (ASSERT_MSG <msg> <test>)")
-	  (return)))
     (if (not (is_string xmsg))
 	(error_plain loc "non string message in (ASSERT_MSG <msg> <test>)"))
     (setq curpair (pair_tail curpair))
@@ -5062,30 +5083,42 @@
     (setq xtest (macroexpand_1 (pair_head curpair) env mexpander))
     (if (pair_tail curpair)
 	(error_plain loc "extra arg for (ASSERT_MSG <msg> <test>)"))
-    (let ( (aprim (make_instance 
-		   class_src_primitive
-		   :src_loc loc
-		   :sprim_oper (unsafe_get_field :pbind_primitive assfail_binding)
-		   :sprim_args (make_tuple3 discr_multiple
+    (let (
+	  (afprim 
+	   (cond ( (is_a assfail_binding class_primitive_binding)
+		   (unsafe_get_field :pbind_primitive assfail_binding))
+		 ( (and (is_a assfail_binding class_value_binding)
+			(is_a (unsafe_get_field :vbind_value assfail_binding) 
+			      class_primitive))
+		   (unsafe_get_field :vbind_value assfail_binding))
+		 (:else
+		  (error_plain loc "ASSERT_FAILED not bound to a primitive in  (ASSERT_MSG <msg> <test>)")
+		  (return)
+		  )))
+	  (aprim (make_instance 
+		  class_src_primitive
+		  :src_loc loc
+		  :sprim_oper afprim
+		  :sprim_args (make_tuple3 discr_multiple
 					   xmsg
 					   (mixint_val loc)
 					   (make_integerbox discr_integer (get_int loc)))))
-	   (atest (make_instance
-		   class_src_ifelse
-		   :src_loc loc
-		   :sif_test xtest
-		   :sif_then ()
-		   :sif_else aprim))
-	   (acppif (make_instance class_src_cppif
-				  :src_loc loc
-				  :sifp_cond 'ENABLE_CHECKING
-				  :sifp_then atest
-				  :sifp_else ()
-				  )) 
-	   )
+	  (atest (make_instance
+		  class_src_ifelse
+		  :src_loc loc
+		  :sif_test xtest
+		  :sif_then ()
+		  :sif_else aprim))
+	  (acppif (make_instance class_src_cppif
+				 :src_loc loc
+				 :sifp_cond 'ENABLE_CHECKING
+				 :sifp_then atest
+				 :sifp_else ()
+				 )) 
+	  )
       (debug_msg acppif "mexpand_assert_msg result acppif")
       (return acppif)
-    )))
+      )))
 (install_initial_macro 'assert_msg mexpand_assert_msg)
 (export_macro assert_msg mexpand_assert_msg)
 
@@ -5430,10 +5463,10 @@
  macroexpand_toplevel_list
  )			  ;end of functions for source representations
 
-;;>> warmelt-macro.bysl
 
 ;;****************************************************************
 
+;;@@<< warmelt-normal.bysl
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; ================ normalized representations
 
@@ -5442,7 +5475,6 @@
 ;; is let y=(g x) in (f a y)
 ;; etc... where y is a cloned symbol
 
-;;<< warmelt-normal.bysl
 ;;; common superclass for normalized representations
 (defclass class_nrep
   :super class_root
@@ -5878,383 +5910,6 @@
  )					;end of export normal classes
 
 
-;;>> warmelt-normal.bysl
-
-
-;;****************************************************************
-
-;;<< warmelt-genobj.bysl
-
-;;;; value like objects
-(defclass class_objvalue
-  :super class_objcode
-  :fields ( obv_type			;the ctype
-))
-
-
-;;; pure values are side-effect free
-(defclass class_objpurevalue
-  :super class_objvalue
-  :fields ())
-
-;; object local variable
-(defclass class_objlocv
-  :super class_objpurevalue
-  :fields (obl_off			;offset in frame
-	   obl_proc			;containing procedure
-	   obl_cname			;symbolic cname string
-))
-
-
-;; closed occurrence
-(defclass class_objcloccv
-  :super class_objpurevalue
-  :fields (obc_off			;offset in closure
-	   obc_proc			;containing procedure
-	   obc_name			;symbolic name
-))
-
-
-;; constant [closed] occurrence
-(defclass class_objconstv
-  :super class_objcloccv
-  :fields (
-))
-
-;; predefined object
-(defclass class_objpredef
-  :super class_objpurevalue
-  :fields (obpredef
-))
-
-;; nil
-(defclass class_objnil
-  :super class_objpurevalue
-  :fields ())
-
-;; initial element 
-(defclass class_objinitelem
-  :super class_objpurevalue
-  :fields (oie_cname 			;symbolic cname string - fieldname in cdat
-	   oie_data			;normal data
-	   oie_discr			;compiled discriminant
-	   oie_locvar			;initial routine's local variable
-	   ;; the size, if any is the obj_num
-))
-
-;;; initial object - see BASILYS_OBJECT_STRUCT in basilys.h
-(defclass class_objinitobject
-  :super class_objinitelem
-  :fields (
-	   oio_predef			;the predef name or number to contain this object
-))
-
-
-;;; initial multiple - see BASILYS_MULTIPLE_STRUCT in basilys.h
-(defclass class_objinitmultiple
-  :super class_objinitelem
-  :fields (
-	   ;; we may need to tuple of compiled values for accessing
-	   ;; the nth at compilation time in compilobj_nrep_multacc
-	   oim_tupval			;tuple of compiled values
-))
-
-;;; initial closure - see BASILYS_CLOSURE_STRUCT in basilys.h
-(defclass class_objinitclosure 
-  :super  class_objinitelem
-  :fields (
-))
-
-;;; initial routine - see  BASILYS_ROUTINE_STRUCT in basilys.h
-(defclass class_objinitroutine
-  :super class_objinitelem
-  :fields (
-	   oir_procroutine		;the procroutine associated
-))
-
-;;; initial string - see BASILYS_STRING_STRUCT in basilys.h
-(defclass class_objinitstring
-  :super class_objinitelem
-  :fields (
-))
-
-
-;; expanded value
-(defclass class_objexpv
-  :super class_objvalue
-  :fields (obx_cont
-))
-
-;; expanded value with location 
-(defclass class_objlocatedexpv
-  :super class_objexpv
-  :fields (obcx_loc			;optional location
-))
-
-;;;; instructions
-(defclass class_objinstr
-  :super class_objcode
-  :fields (obi_loc			;src location
-))
-
-
-;;;; instructions with a list of destinations (computes, calls, sends, etc...)
-(defclass class_objdestinstr
-  :super class_objinstr
-  :fields (obdi_destlist		;a list of destination lovations
-))
-
-;;; compute instruction
-(defclass class_objcompute
-  :super class_objdestinstr
-  :fields (obcpt_expr			;expression list or object or tuple
-))
-
-;; get argument instruction
-(defclass class_objgetarg
-  :super class_objinstr
-  :fields (obarg_obloc			;objlocation
-	   obarg_bind			;formal binding
-))
-
-
-;; put extra result instruction
-(defclass class_objputxtraresult
-  :super class_objinstr
-  :fields (obxres_rank 			;boxed rank
-	   obxres_obloc			;objlocation
-))
-
-;; final return
-(defclass class_objfinalreturn
-  :super class_objinstr
-  :fields (				;no argument
-))
-
-;; clear instruction
-(defclass class_objclear
-  :super class_objinstr
-  :fields (oclr_vloc			;varlocation to clear
-))
-
-;; block instruction
-(defclass class_objblock
-  :super class_objinstr
-  :fields ( oblo_bodyl			;body list
-	    oblo_epil			;epilogue list
-))
-
-;; a block with a comment string appearing in the generated code
-(defclass class_objcommentedblock
-  :super class_objblock
-  :fields ( ocomblo_comment		;the comment string
-))
-
-;; looping block
-(defclass class_objloop
-  :super class_objblock		 ;the body is looped, not the epilogue
-  :fields (obloop_label		 ;cloned symbol
-	   obloop_resv		 ;the result of the loop
-))
-
-;; exit a loop
-(defclass class_objexit
-  :super class_objinstr
-  :fields (obexit_label			;cloned symbol for goto destination
-))
-
-;; conditional instruction
-(defclass class_objcond
-  :super class_objinstr
-  :fields (obcond_test
-	   obcond_then
-	   obcond_else
-))
-
-;; preprocessor conditional instruction
-(defclass class_objcppif
-  :super class_objinstr
-  :fields (obifp_cond
-	   obifp_then
-	   obifp_else
-))
-
-;;; keyword & symbol intern instruction
-(defclass class_objinterncommon
-  :super class_objinstr
-  :fields (obintern_iobj			;the objinitobject for
-						;the symbol or keyword
-))
-
-(defclass class_objinternsymbol
-  :super class_objinterncommon
-  :fields (
-))
-
-(defclass class_objinternkeyword
-  :super class_objinterncommon
-  :fields (
-))
-
-;;; keyword & symbol getnamed instruction
-(defclass class_objgetnamedcommon
-  :super class_objinstr
-  :fields (obgnamed_iobj		;the objinitobject for the
-					;symbol or keyword
-))
-
-(defclass class_objgetnamedsymbol
-  :super class_objgetnamedcommon
-  :fields (
-))
-
-(defclass class_objgetnamedkeyword
-  :super class_objgetnamedcommon
-  :fields (
-))
-
-;;; apply instruction
-(defclass class_objapply
-  :super class_objdestinstr
-  :fields (obapp_clos			;closure to be applied
-	   obapp_args			;argument tuple
-))
-
-;;; multiapply instruction
-(defclass class_objmultiapply
-  :super class_objapply
-  :fields (obmultapp_xres		;extraresult tuple
-))
-
-;;; message send instruction
-(defclass class_objmsend
-  :super class_objdestinstr
-  :fields (obmsnd_sel			;selector object (compiled)
-	   obmsnd_recv			;message reciever (compiled)
-	   obmsnd_args 			;argument tuple (compiled)
-))
-
-;;; multisend instruction
-(defclass class_objmultimsend
-  :super class_objmsend
-  :fields (obmultsnd_xres		;extraresult tuple
-))
-
-;; raw object allocation instruction
-(defclass class_objrawallocobj
-  :super class_objdestinstr
-  :fields (
-	   obrallobj_class		;the class data
-	   obrallobj_len		;the boxed integer length
-))
-
-
-;; new closure allocation
-(defclass class_objnewclosure
-  :super class_objdestinstr
-  :fields (obnclo_discr		     ;the discriminant
-	   obnclo_rout		     ;the routine
-	   obnclo_len		     ;the boxed integer length
-))
-
-;; put a component inside a tuple
-(defclass class_objputuple
-  :super class_objinstr
-  :fields (oputu_tupled			;the tuple data
-	   oputu_offset			;numerical offset
-	   oputu_value			;the new value
-))
-
-;; put a slot inside an object
-(defclass class_objputslot
-  :super class_objinstr
-  :fields ( oslot_odata			;the object data to put
-	    oslot_offset		;numerical offset
-	    oslot_field			;the [optional] field (only for generated comment)
-	    oslot_value			;the new value
-))
-
-
-;; get a slot from an object
-(defclass class_objgetslot
-  :super class_objdestinstr
-  :fields (ogetsl_obj		   ;the object to get from
-	   ogetsl_field		   ;the fieldname
-))
-
-;; put the routine inside a closure
-(defclass class_objputclosurout
-  :super class_objinstr
-  :fields (opclor_clos			;the closure data
-	   opclor_rout			;the routine data
-))
-
-;; put a closed value inside a closure
-(defclass class_objputclosedv
-  :super class_objinstr
-  :fields (opclov_clos			;the closure data or local
-	   opclov_off 			;the boxed offset
-	   opclov_cval			;the closed value
-))
-
-;; put a constant value inside a routine
-(defclass class_objputroutconst
-  :super class_objinstr
-  :fields (oprconst_rout	 ;the routine data
-	   oprconst_off		 ;the boxed offset
-	   oprconst_cval	 ;the constant value
-))
-
-;; touch a value, with a tiny comment
-(defclass class_objtouch
-  :super class_objinstr
-  :fields (otouch_val
-	   otouch_comment
-))
-
-;; set a predef
-(defclass class_objsetpredef
- :super class_objinstr
- :fields ( ospr_object			;the object 
-	   ospr_predef			;its predef rank
-))
-
-
-;;; routines
-(defclass class_routineobj
-  :super class_named
-  :fields (obrout_proc			;the associated procedure
-	   obrout_body			;the body (a list)
-	   obrout_nbval			;the boxed number of value pointers
-	   obrout_nblong		;the boxed number of longs
-	   ;;; if double are needed, we might later add some obrout_nbdouble
-	   obrout_others		;the list of other (nonvalue,
-					;nonlongs) locals (usually C
-					;pointers like tree-s,
-					;cstrings, ...)
-	   obrout_retval		;the main return value
-))
-
-;; procedure routine
-(defclass class_procroutineobj
-  :super class_routineobj
-  :fields (oprout_getargs		;the get arguments tuple of instructions
-	   oprout_loc			;the source location
-	   oprout_funam			;function name
-))
-
-;; initial routine
-(defclass class_initialroutineobj
-  :super class_routineobj
-  :fields (
-	   oirout_data			;the tuple of initial data
-	   oirout_fill			;the fill of the data (a list of instr)
-))
-
-
-
-
-;;>> warmelt-genobj.bysl
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -6415,6 +6070,7 @@
       (return ncx)
       )))
 
+
 ;;; the normal_exp selector 
 ;;;;; expected arguments: 
 ;;;   recv = the reciever, eg a sexpr
@@ -6470,6 +6126,7 @@
 (defselector get_ctype class_selector
 ;  :named_name (stringconst2val discr_namestring "GET_CTYPE")
 )
+
 ;;; most stuff are really ctype_value
 (defun gectyp_anyrecv (recv env) ctype_value)
 (install_method discr_anyrecv get_ctype gectyp_anyrecv)
@@ -6546,7 +6203,6 @@
 	 )
     (return wnlet)))
     
-
 ;; wrap a normal let around a single normalized expression & a bindinglist
 (defun wrap_normal_let1 (nexp bindlist loc)
   (assert_msg "check bindlist" (is_list_or_null bindlist))
@@ -6572,6 +6228,29 @@
     nexp
 ))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; utility to check that every normalized argument has a passable ctype
+(defun check_ctype_nargs (nargs env sloc)
+  (multiple_every 
+   nargs
+   (lambda (cnarg :long ix) 
+     (let ( (ctyp (get_ctype cnarg env)) )
+       (assert_msg "check_ctype_nargs ctyp" (is_a ctyp class_ctype))
+       (if (not (is_string (unsafe_get_field :ctype_parstring ctyp)))
+	   (error_strv sloc "argument has invalid type" (unsafe_get_field :named_name ctyp))
+     ))
+)))
+
+(export_values
+ create_normcontext
+ normal_exp
+ get_ctype
+ normalize_tuple
+ wrap_normal_letseq
+ wrap_normal_let1
+ check_ctype_nargs
+)
+
 
 ; for symbols which are imported from a previous environment (this
 ; only happens when compiling stuff which is not this warm-basilys) we
@@ -6840,6 +6519,7 @@
 	    (:long nbarg (multiple_length nargs))
 	    (:long nbexp (multiple_length sopexp))
 	    )
+       (assert_msg "check soptype" (is_a soptype class_ctype))
        (if (!=i nbarg (multiple_length sopformals))
 	   (progn
 	     (error_strv sloc "length mismatch between formals & actuals in primitive" 
@@ -6911,18 +6591,380 @@
 		    (assert_msg "check prim" (is_a prim class_primitive))
 		    (unsafe_get_field :prim_type prim))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; utility to check that every normalized argument has a passable ctype
-(defun check_ctype_nargs (nargs env sloc)
-  (multiple_every 
-   nargs
-   (lambda (cnarg :long ix) 
-     (let ( (ctyp (get_ctype cnarg env)) )
-       (assert_msg "check_ctype_nargs ctyp" (is_a ctyp class_ctype))
-       (if (not (is_string (unsafe_get_field :ctype_parstring ctyp)))
-	   (error_strv sloc "argument has invalid type" (unsafe_get_field :named_name ctyp))
-     ))
-)))
+
+;;****************************************************************
+;;@@<< warmelt-genobj.bysl
+
+;;;; value like objects
+(defclass class_objvalue
+  :super class_objcode
+  :fields ( obv_type			;the ctype
+))
+
+
+;;; pure values are side-effect free
+(defclass class_objpurevalue
+  :super class_objvalue
+  :fields ())
+
+;; object local variable
+(defclass class_objlocv
+  :super class_objpurevalue
+  :fields (obl_off			;offset in frame
+	   obl_proc			;containing procedure
+	   obl_cname			;symbolic cname string
+))
+
+
+;; closed occurrence
+(defclass class_objcloccv
+  :super class_objpurevalue
+  :fields (obc_off			;offset in closure
+	   obc_proc			;containing procedure
+	   obc_name			;symbolic name
+))
+
+
+;; constant [closed] occurrence
+(defclass class_objconstv
+  :super class_objcloccv
+  :fields (
+))
+
+;; predefined object
+(defclass class_objpredef
+  :super class_objpurevalue
+  :fields (obpredef
+))
+
+;; nil
+(defclass class_objnil
+  :super class_objpurevalue
+  :fields ())
+
+;; initial element 
+(defclass class_objinitelem
+  :super class_objpurevalue
+  :fields (oie_cname 			;symbolic cname string - fieldname in cdat
+	   oie_data			;normal data
+	   oie_discr			;compiled discriminant
+	   oie_locvar			;initial routine's local variable
+	   ;; the size, if any is the obj_num
+))
+
+;;; initial object - see BASILYS_OBJECT_STRUCT in basilys.h
+(defclass class_objinitobject
+  :super class_objinitelem
+  :fields (
+	   oio_predef			;the predef name or number to contain this object
+))
+
+
+;;; initial multiple - see BASILYS_MULTIPLE_STRUCT in basilys.h
+(defclass class_objinitmultiple
+  :super class_objinitelem
+  :fields (
+	   ;; we may need to tuple of compiled values for accessing
+	   ;; the nth at compilation time in compilobj_nrep_multacc
+	   oim_tupval			;tuple of compiled values
+))
+
+;;; initial closure - see BASILYS_CLOSURE_STRUCT in basilys.h
+(defclass class_objinitclosure 
+  :super  class_objinitelem
+  :fields (
+))
+
+;;; initial routine - see  BASILYS_ROUTINE_STRUCT in basilys.h
+(defclass class_objinitroutine
+  :super class_objinitelem
+  :fields (
+	   oir_procroutine		;the procroutine associated
+))
+
+;;; initial string - see BASILYS_STRING_STRUCT in basilys.h
+(defclass class_objinitstring
+  :super class_objinitelem
+  :fields (
+))
+
+
+;; expanded value
+(defclass class_objexpv
+  :super class_objvalue
+  :fields (obx_cont
+))
+
+;; expanded value with location 
+(defclass class_objlocatedexpv
+  :super class_objexpv
+  :fields (obcx_loc			;optional location
+))
+
+;;;; instructions
+(defclass class_objinstr
+  :super class_objcode
+  :fields (obi_loc			;src location
+))
+
+
+;;;; instructions with a list of destinations (computes, calls, sends, etc...)
+(defclass class_objdestinstr
+  :super class_objinstr
+  :fields (obdi_destlist		;a list of destination lovations
+))
+
+;;; compute instruction
+(defclass class_objcompute
+  :super class_objdestinstr
+  :fields (obcpt_expr			;expression list or object or tuple
+))
+
+;; get argument instruction
+(defclass class_objgetarg
+  :super class_objinstr
+  :fields (obarg_obloc			;objlocation
+	   obarg_bind			;formal binding
+))
+
+
+;; put extra result instruction
+(defclass class_objputxtraresult
+  :super class_objinstr
+  :fields (obxres_rank 			;boxed rank
+	   obxres_obloc			;objlocation
+))
+
+;; final return
+(defclass class_objfinalreturn
+  :super class_objinstr
+  :fields (				;no argument
+))
+
+;; clear instruction
+(defclass class_objclear
+  :super class_objinstr
+  :fields (oclr_vloc			;varlocation to clear
+))
+
+;; block instruction
+(defclass class_objblock
+  :super class_objinstr
+  :fields ( oblo_bodyl			;body list
+	    oblo_epil			;epilogue list
+))
+
+;; a block with a comment string appearing in the generated code
+(defclass class_objcommentedblock
+  :super class_objblock
+  :fields ( ocomblo_comment		;the comment string
+))
+
+;; looping block
+(defclass class_objloop
+  :super class_objblock		 ;the body is looped, not the epilogue
+  :fields (obloop_label		 ;cloned symbol
+	   obloop_resv		 ;the result of the loop
+))
+
+;; exit a loop
+(defclass class_objexit
+  :super class_objinstr
+  :fields (obexit_label			;cloned symbol for goto destination
+))
+
+;; conditional instruction
+(defclass class_objcond
+  :super class_objinstr
+  :fields (obcond_test
+	   obcond_then
+	   obcond_else
+))
+
+;; preprocessor conditional instruction
+(defclass class_objcppif
+  :super class_objinstr
+  :fields (obifp_cond
+	   obifp_then
+	   obifp_else
+))
+
+;;; keyword & symbol intern instruction
+(defclass class_objinterncommon
+  :super class_objinstr
+  :fields (obintern_iobj			;the objinitobject for
+						;the symbol or keyword
+))
+
+(defclass class_objinternsymbol
+  :super class_objinterncommon
+  :fields (
+))
+
+(defclass class_objinternkeyword
+  :super class_objinterncommon
+  :fields (
+))
+
+;;; keyword & symbol getnamed instruction
+(defclass class_objgetnamedcommon
+  :super class_objinstr
+  :fields (obgnamed_iobj		;the objinitobject for the
+					;symbol or keyword
+))
+
+(defclass class_objgetnamedsymbol
+  :super class_objgetnamedcommon
+  :fields (
+))
+
+(defclass class_objgetnamedkeyword
+  :super class_objgetnamedcommon
+  :fields (
+))
+
+;;; apply instruction
+(defclass class_objapply
+  :super class_objdestinstr
+  :fields (obapp_clos			;closure to be applied
+	   obapp_args			;argument tuple
+))
+
+;;; multiapply instruction
+(defclass class_objmultiapply
+  :super class_objapply
+  :fields (obmultapp_xres		;extraresult tuple
+))
+
+;;; message send instruction
+(defclass class_objmsend
+  :super class_objdestinstr
+  :fields (obmsnd_sel			;selector object (compiled)
+	   obmsnd_recv			;message reciever (compiled)
+	   obmsnd_args 			;argument tuple (compiled)
+))
+
+;;; multisend instruction
+(defclass class_objmultimsend
+  :super class_objmsend
+  :fields (obmultsnd_xres		;extraresult tuple
+))
+
+;; raw object allocation instruction
+(defclass class_objrawallocobj
+  :super class_objdestinstr
+  :fields (
+	   obrallobj_class		;the class data
+	   obrallobj_len		;the boxed integer length
+))
+
+
+;; new closure allocation
+(defclass class_objnewclosure
+  :super class_objdestinstr
+  :fields (obnclo_discr		     ;the discriminant
+	   obnclo_rout		     ;the routine
+	   obnclo_len		     ;the boxed integer length
+))
+
+;; put a component inside a tuple
+(defclass class_objputuple
+  :super class_objinstr
+  :fields (oputu_tupled			;the tuple data
+	   oputu_offset			;numerical offset
+	   oputu_value			;the new value
+))
+
+;; put a slot inside an object
+(defclass class_objputslot
+  :super class_objinstr
+  :fields ( oslot_odata			;the object data to put
+	    oslot_offset		;numerical offset
+	    oslot_field			;the [optional] field (only for generated comment)
+	    oslot_value			;the new value
+))
+
+
+;; get a slot from an object
+(defclass class_objgetslot
+  :super class_objdestinstr
+  :fields (ogetsl_obj		   ;the object to get from
+	   ogetsl_field		   ;the fieldname
+))
+
+;; put the routine inside a closure
+(defclass class_objputclosurout
+  :super class_objinstr
+  :fields (opclor_clos			;the closure data
+	   opclor_rout			;the routine data
+))
+
+;; put a closed value inside a closure
+(defclass class_objputclosedv
+  :super class_objinstr
+  :fields (opclov_clos			;the closure data or local
+	   opclov_off 			;the boxed offset
+	   opclov_cval			;the closed value
+))
+
+;; put a constant value inside a routine
+(defclass class_objputroutconst
+  :super class_objinstr
+  :fields (oprconst_rout	 ;the routine data
+	   oprconst_off		 ;the boxed offset
+	   oprconst_cval	 ;the constant value
+))
+
+;; touch a value, with a tiny comment
+(defclass class_objtouch
+  :super class_objinstr
+  :fields (otouch_val
+	   otouch_comment
+))
+
+;; set a predef
+(defclass class_objsetpredef
+ :super class_objinstr
+ :fields ( ospr_object			;the object 
+	   ospr_predef			;its predef rank
+))
+
+
+;;; routines
+(defclass class_routineobj
+  :super class_named
+  :fields (obrout_proc			;the associated procedure
+	   obrout_body			;the body (a list)
+	   obrout_nbval			;the boxed number of value pointers
+	   obrout_nblong		;the boxed number of longs
+	   ;;; if double are needed, we might later add some obrout_nbdouble
+	   obrout_others		;the list of other (nonvalue,
+					;nonlongs) locals (usually C
+					;pointers like tree-s,
+					;cstrings, ...)
+	   obrout_retval		;the main return value
+))
+
+;; procedure routine
+(defclass class_procroutineobj
+  :super class_routineobj
+  :fields (oprout_getargs		;the get arguments tuple of instructions
+	   oprout_loc			;the source location
+	   oprout_funam			;function name
+))
+
+;; initial routine
+(defclass class_initialroutineobj
+  :super class_routineobj
+  :fields (
+	   oirout_data			;the tuple of initial data
+	   oirout_fill			;the fill of the data (a list of instr)
+))
+
+
+
+
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; normalize an application
@@ -7719,13 +7761,25 @@
     (let ( (nvar (normexp_symbol svar env ncx sloc)) 
 	   (varctyp (get_ctype nvar env))
 	   )
+      (debug_msg varctyp "normexp_setq varctyp")
+      (assert_msg "check varctyp" (is_a varctyp class_ctype))
       (multicall
        (nexp nbind)
        (normal_exp sexp env ncx sloc)
        (if (null nbind) (setq nbind (make_list discr_list)))
-       (if (!= varctyp (get_ctype nexp env))
-	   (error_strv sloc "incompatible type for SETQ"
-		       (unsafe_get_field :named_name svar)))
+       (let ( (expctyp (get_ctype nexp env))
+	      )
+	 (debug_msg expctyp "normexp_setq expctyp")
+	 (assert_msg "check expctyp" (is_a expctyp class_ctype))
+	 (if (!= varctyp expctyp)
+	     (progn
+	       (error_strv sloc "incompatible type for SETQ"
+			   (unsafe_get_field :named_name svar))
+	       (inform_strv sloc "left [var] type for incomatible SETQ"
+			    (unsafe_get_field :named_name varctyp))
+	       (inform_strv sloc "right [expr] type for incomatible SETQ"
+			    (unsafe_get_field :named_name expctyp))
+	   )))
        (let ( (csym (clone_symbol 'setq_)) 
 	      (cbind  (make_instance class_normlet_binding
 				     :binder csym
@@ -8671,10 +8725,12 @@
 		      :nstr_string (unsafe_get_field :named_name sname))))
     (fill_data_slot nprimdata prim_formals nargdata)
     (fill_data_slot nprimdata prim_expansion nexpdata)
+    (fill_data_slot nprimdata prim_type
+		    (normal_predef stype ncx sloc "primitive res type"))
 ;;; put the data into the primitive binding
     (if (is_a sprimbind class_primitive_binding)
 	(unsafe_put_fields sprimbind :pbind_primdata nprimdata))
-    (return (the_null))			     ;normalized defprimitive is empty
+    (return (the_null))		     ;normalized defprimitive is empty
     ))
 (install_method class_src_defprimitive normal_exp normexp_defprimitive)