path: root/gcc/melt/warmelt-genobj.melt

 ;; File warmelt-genobj.melt -*- Lisp -*-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (comment "***
     Copyright 2008 - 2014  Free Software Foundation, Inc.
     Contributed by Basile Starynkevitch <basile@starynkevitch.net>

     This file is part of GCC.

     GCC is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 3, or (at your option)
     any later version.

     GCC is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.

     You should have received a copy of the GNU General Public License
     along with GCC; see the file COPYING3.  If not see
     <http://www.gnu.org/licenses/>.
 ***")

 ;; the copyright notice above apply both to warmelt-genobj.melt and 
 ;; to the generated file  warmelt-genobj*.c


;; This MELT module is GPL compatible since it is GPLv3+ licensed.
(module_is_gpl_compatible "GPLv3+")

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 ;;    This file is part of a bootstrapping compiler for the MELT lisp
 ;;    dialect, compiler which should be able to compile itself (into
 ;;    generated C file[s])
 ;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


 ;; Notice: the threshold governing the splitting and length of
 ;; generated secondary C files are wired in constants inside the
 ;; compile2obj_procedure function.


 ;;;; value like objects;; value here is meant in the sense of the C or C++
 ;;;; language so can be any thing.
 (defclass class_objvalue
   :super class_generated_c_code
   :fields ( obv_type			;the ctype
	     ))


 ;;; pure values expressions are side-effect free
 (defclass class_objpurevalue
   :super class_objvalue
   :fields ())


 ;; formal arguments in C routines, notably in hooks
 (defclass class_objcformal
   :super class_objpurevalue
   :fields (oformal_name			;the verbatim name
	    oformal_proc			;the containing proc
	    oformal_bind			;the associated formal binding
	    oformal_locv			;the associated stack location
	    ))

 ;; object local variable
 ;;;; disposed local variables can be reused.
 (defclass class_objlocv
   :super class_objpurevalue
   :fields (obl_off			;offset in frame
	    obl_proc			;containing procedure or nil if disposed
	    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 (
	    ))

 ;; hook closed occurrence
 (defclass class_objclohookv
   :super class_objcloccv
   :fields (
	    ))

 ;; fetch a module variable
 (defclass class_objfetchmodvar 
   :super class_objpurevalue
   :fields (obfetchmodvar_bind ;; the normal module variable binding
	    ))

 ;; predefined object
 (defclass class_objpredef
   :super class_objpurevalue
   :fields (obpredef
	    ))

 ;; nil
 (defclass class_objnil
   :super class_objpurevalue
   :fields ())

 ;; expanded pure C value, side-effect-free so could be non-emitted
 (defclass class_objexpandpureval
   :super class_objpurevalue
   :fields (oxpurval_loc			;optional source location
	    oxpurval_comm		;optional comment
	    oxpurval_cont		;expanded content chunk
 ))

 ;; 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 MELT_OBJECT_STRUCT in melt-runtime.h
 (defclass class_objinitobject
   :super class_objinitelem
   :fields (
	    oio_predef			;the predef name or number to contain this object
	    oio_class			;the class of the object
	    ))

 ;;; some initial objects, such as existing symbols, should not be
 ;;; recreated if they already exist. Use this class for them.
 (defclass class_objinituniqueobject
   :super class_objinitobject
   :fields (
	    ))


 ;;; initial multiple - see MELT_MULTIPLE_STRUCT in melt-runtime.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 MELT_CLOSURE_STRUCT in melt-runtime.h
 (defclass class_objinitclosure 
   :super  class_objinitelem
   :fields (oiclo_rout			;the compiled routine of the
					 ;closure, useful for lambda-s
					 ;in letrec-s
	    ))

 ;;; initial routine - see  MELT_ROUTINE_STRUCT in melt-runtime.h
 (defclass class_objinitroutine
   :super class_objinitelem
   :fields (
	    oir_procroutine		;the associated procroutine
	    ))


 ;;; initial hook - see MELT_HOOK_STRUCT 
 (defclass class_objinithook 
   :super class_objinitelem
   :fields (oihk_prochook		;the associated prochook
	    oihk_data			;the data description
	    oihk_cloval			;the tuple of closed values in the hook
	    oihk_predef 			;the predefined, if any
	    oihk_modvarbind		;the module variable binding if any
	    ))

 ;;; initial string - see MELT_STRING_STRUCT in melt-runtime.h
 (defclass class_objinitstring
   :super class_objinitelem
   :fields (
	    ))

 ;;; initial pair - see struct meltpair_st in melt-runtime.h
 (defclass class_objinitpair
   :super class_objinitelem
   :fields ())

 ;;; initial list - see struct meltlist_st in melt-runtime.h
 (defclass class_objinitlist
   :super class_objinitelem
   :fields ())


 ;;; initial boxed int - see struct meltint_st in melt-runtime.h
 (defclass class_objinitboxinteger
   :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
	    ))


 (defclass class_objflag
   :super class_objpurevalue
   :fields (obflag_matchflag
	    obflag_name
	    obflag_rank
	    ))

 ;;;; instructions
 (defclass class_objinstr
   :super class_generated_c_code
   :fields (obi_loc			;src location
	    ))

 (defclass class_objcommentinstr		;just a comment, useful only for debugging our generator
   :super class_objinstr
   :fields (obci_comment
	    ))

 (defclass class_objchecksignal
   :super class_objinstr
   :fields (
	    ))

 ;;;; 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
	    obcpt_type			;ctype of expression
	    ))

 (defclass class_objputmodvar
   :super class_objinstr
   :fields (obputmodvar_bind
	    obputmodvar_val))

 ;; get argument instruction
 (defclass class_objgetarg
   :super class_objinstr
   :fields (obarg_obloc			;objlocation
	    obarg_bind			;formal binding
	    ))

 ;; put output argument instruction, usful inside hooks
 (defclass class_objputoutarg
   :super class_objinstr
   :fields (oboutarg_formal			;;formal out argument of class_objcformal
	    ))

 ;; get argument & update rest index in variadic instruction
 (defclass class_objgetargrest
   :super class_objgetarg
   :fields (obarg_rest ;name prefix of rest index, as a string
	    ))


 ;; 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_objanyblock
   :super class_objinstr
   :fields ( oblo_bodyl			;body list
	     oblo_epil			;epilogue list
	     ))

 (defclass class_objplainblock
   :super class_objanyblock
   :fields (
	    ))



 ;; multi-allocation block instruction, used for letrec compilation
 (defclass class_objmultiallocblock
   :super class_objanyblock
   :fields ( omalblo_allstruct		;the allocated structure is a
					 ;tuple of class_objinitelem
	     omalblo_name		;unique name
 ))

 ;; a block with a comment string appearing in the generated code
 (defclass class_objcommentedblock
   :super class_objanyblock
   :fields ( ocomblo_comment		;the comment string
	     ))


 ;; a block for compiling matches. We need to redistribute put_objdest
 ;; inside appropriately
 (defclass class_objmultiblock
   :super class_objanyblock
   :fields (omulblo_subcomp		;the tuple of subcomponents
					 ;into which redistribute
					 ;destination
	    ))

 ;; a block for compiling new matches with flags
 (defclass class_objmatchflagblock
   :super class_objanyblock
   :fields (omchflgblo_flags 		;the tuple of flags
	    ))

 ;; unique label instr
 (defclass class_objlabelinstr
   :super class_objinstr
   :fields (oblab_prefix			;unique prefix string
	    oblab_rank			;additional rank
	    ))

 ;; unconditional goto label
 (defclass class_objgotoinstr
   :super class_objinstr
   :fields (obgoto_prefix		;unique prefix string
	    obgoto_rank			;additional rank
	    ))

 ;; looping block
 (defclass class_objloop
   :super class_objanyblock		 ;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
	    ))

 ;; start again a loop
 (defclass class_objagain
   :super class_objinstr
   :fields (obagain_label			;cloned symbol for goto destination
	    ))


 ;; citeration block
 (defclass class_objciterblock
   :super class_objanyblock
   :fields (obciter_citer
	    obciter_before
	    obciter_after
	    ))

 ;; 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 receiver (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
	    obrallobj_classname		;the class name
	    ))

 ;; instruction for debugtracing of written or created objects, for low
 ;; level debug purposes using GDB, see melt_dbgtrace_write_object in
 ;; runtime.
 (defclass class_objdbgtracewriteobj
   :super  class_objinstr
   :fields (obdtw_writtenobj		;the changed object
	    obdtw_message			;the message
	    ))


 ;; 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 inside a pair
 (defclass class_objputpair
   :super class_objinstr
   :fields (oputp_pair 			;the pair to update
	    ))

 (defclass class_objputpairhead
   :super class_objputpair
   :fields (oputp_head			;the head to put
	    ))

 (defclass class_objputpairtail
   :super class_objputpair
   :fields (oputp_tail			;the tail to put
	    ))

 ;; put the first and last inside a list
 (defclass class_objputlist
   :super class_objinstr
   :fields (oputl_list			;the list to update
	    oputl_first			;the first pair
	    oputl_last			;the last pair
	    ))

 ;; 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 
	     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
	    ))

 ;; likewise, but check that the closed value is notnull
 (defclass class_objputclosednotnullv
   :super class_objputclosedv
   :fields (
	    ))

 ;; put a constant value inside a hook
 (defclass class_objputhookconst
   :super class_objinstr
   :fields (ophconst_hook	 ;the hook data
	    ophconst_off		 ;the boxed offset
	    ophconst_cval	 ;the constant value
	    ))

 ;; unsafely retrieve the hook nth "closed" data
 (defclass class_objhooknth
   :super class_objpurevalue
   :fields (ohknth_hook			;the hook
	    ohknth_off			;the boxed offset
	    ))

 ;; put a constant data inside a hook
 (defclass class_objputhookdata
   :super class_objinstr
   :fields (ophkdata_hook	 ;the hook
	    ophkdata_data	 ;the data
	    ))

 ;; 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
	    ))

 ;; likewise, but check that the constant is notnull
 (defclass class_objputroutconstnotnull
   :super class_objputroutconst
   :fields (
	    ))

 ;; 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_protoroutineobj
  :super class_named
  :fields (oprout_loc 			;source location
	   oprout_filenum		;boxed C file number
	   ))
	   
 (defclass class_routineobj
   :super class_protoroutineobj
   :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
	    obrout_others		;the list of other (nonvalue,
					 ;nonlongs) locals (usually C
					 ;pointers like tree-s,
					 ;cstrings, ...)
	    obrout_retval		;the main return value
	    obrout_cntciter		;the boxed counter of citerations
	    obrout_cntletrec		;the boxed counter of letrecs
	    ))

 ;; procedure routine
 (defclass class_procroutineobj
   :super class_routineobj
   :fields (oprout_getargs		;the get arguments tuple of instructions
	    oprout_funam			;function name
	    oprout_restnam		;the name used for variadic arguments, or else null
	    ))


 ;; any initial or hook routine is a start routine
 (defclass class_any_start_routineobj
   :super class_routineobj
   :fields (
	    )
   )

 ;; hook routine
 (defclass class_hookroutineobj
   :super class_any_start_routineobj
   :fields (
	    ohookrout_datarg		;the argument for the data
	    ohookrout_inargs
	    ohookrout_outargs
	    ohookrout_epilog		;list of objinstr after the
					 ;meltlabend_rout label
	    ))

 ;; initial routine common super-class
 (defclass class_initialroutineobj
   :super class_any_start_routineobj
   :fields (
	    oirout_data			;the tuple of initial data
	    oirout_prolog       ;the prologue (list of instr) before filling the data. Imports should go here!
	    oirout_fill			;the fill of the data (a list of instr)
	    oirout_modctx		;the module context
	    ))

 ;; initial routine in modules
 (defclass class_initial_module_routineobj
   :super class_initialroutineobj
   :fields (
	    ))

 ;; initial routine in extensions
 (defclass class_initial_extension_routineobj
   :super class_initialroutineobj
   :fields (
	    ))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; export the above classes
 (export_class				;alphabetical order
  class_any_start_routineobj
  class_hookroutineobj
  class_initial_extension_routineobj
  class_initial_module_routineobj
  class_initialroutineobj
  class_objagain
  class_objanyblock
  class_objapply
  class_objcformal
  class_objchecksignal
  class_objciterblock
  class_objclear
  class_objcloccv 
  class_objclohookv
  class_objcommentedblock
  class_objcommentinstr
  class_objcompute
  class_objcond
  class_objconstv
  class_objcppif
  class_objdbgtracewriteobj
  class_objdestinstr
  class_objexit
  class_objexpandpureval
  class_objexpv
  class_objfetchmodvar
  class_objfinalreturn
  class_objflag
  class_objgetarg
  class_objgetargrest
  class_objgetnamedcommon
  class_objgetnamedkeyword
  class_objgetnamedsymbol
  class_objgetslot
  class_objgotoinstr
  class_objhooknth
  class_objinitboxinteger
  class_objinitclosure
  class_objinitelem
  class_objinithook
  class_objinitlist
  class_objinitmultiple
  class_objinitobject
  class_objinitpair
  class_objinitroutine
  class_objinitstring
  class_objinituniqueobject
  class_objinstr
  class_objinterncommon
  class_objinternkeyword
  class_objinternsymbol
  class_objlabelinstr
  class_objlocatedexpv
  class_objlocv
  class_objloop
  class_objmatchflagblock
  class_objmsend
  class_objmultiallocblock
  class_objmultiapply
  class_objmultiblock
  class_objmultimsend
  class_objnewclosure
  class_objnil
  class_objplainblock
  class_objpredef
  class_objpurevalue
  class_objputclosednotnullv
  class_objputclosedv
  class_objputclosurout
  class_objputhookconst
  class_objputhookdata
  class_objputlist
  class_objputoutarg
  class_objputpair
  class_objputpairhead
  class_objputpairtail
  class_objputmodvar
  class_objputroutconst
  class_objputroutconstnotnull
  class_objputslot
  class_objputuple
  class_objputxtraresult
  class_objrawallocobj
  class_objsetpredef
  class_objtouch
  class_objvalue
  class_procroutineobj
  class_protoroutineobj
  class_routineobj
  )					;end export_class

 (export_synonym class_objblock class_objplainblock)
 (export_synonym class_objcheckinterrupt class_objchecksignal)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; variadic function to make an objlocatedexpv out of a macrostring
 (defun make_objlocatedexp (loc cty :rest)
   (debug "make_objlocatedexp loc=" loc " cty=" cty)
   (assert_msg "make_objlocatedexp check loc" (or (null loc)
						  (is_a loc discr_mixed_location)
						  (is_a loc discr_mixed_integer))
	       loc)
   (assert_msg "make_objlocatedexp check cty" (is_a cty class_ctype) cty)
   (let ( (arglist (make_list discr_list)) 
	  )
     (forever 
      argloop
      (variadic ( () 
		  (exit argloop))
		( (:long l)
		  (let ( (bl (make_integerbox discr_constant_integer l))
			 )
		    (list_append arglist bl)))
		( (:cstring s)
		  (let ( (bs (make_stringconst discr_verbatim_string s)) 
			 )
		    (list_append arglist bs)))
		( (:value v)
		  (cond ( (is_list v)
			  (list_append2list arglist v))
			( (is_multiple v)
			  (foreach_in_multiple
			   (v)
			   (curcomp :long ix)
			   (list_append arglist curcomp)))
			( (is_closure v)
			  (v arglist))
			(:else
			 (list_append arglist v))))
		( :else
		  (debug "make_objlocatedexp varargctype=" (variadic_ctype 0))
		  (assert_msg "unexpected variable argument for make_objlocatedexp" () (variadic_ctype 0)))
		))
     (debug "make_objlocatedexp arglist=" arglist)
     (let ( (res
	     (instance  class_objlocatedexpv
			:obv_type cty
			:obx_cont (list_to_multiple arglist discr_multiple)
			:obcx_loc loc))
	    )
       (debug "make_objlocatedexp res=" res)
       (return res)
       )))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; variadic function to make an objcompute out of a macrostring
 (defun make_objcompute (loc ctyp :rest)
   (debug "make_objcompute loc=" loc)
   (assert_msg "make_objcompute check loc" (or (null loc) (is_a loc discr_mixed_location)) loc)
   (assert_msg "make_objcompute check ctyp" (is_a ctyp class_ctype) ctyp)
   (let ( (arglist (make_list discr_list)) 
	  )
     (forever 
      argloop
      (variadic ( () 
		  (exit argloop))
		( (:long l)
		  (let ( (bl (make_integerbox discr_constant_integer l))
			 )
		    (list_append arglist bl)))
		( (:cstring s)
		  (let ( (bs (make_stringconst discr_verbatim_string s)) 
			 )
		    (list_append arglist bs)))
		( (:value v)
		  (cond ( (is_list v)
			  (list_append2list arglist v))
			( (is_multiple v)
			  (foreach_in_multiple
			   (v)
			   (curcomp :long ix)
			   (list_append arglist curcomp)))
			(:else
			 (list_append arglist v))))
		( :else
		  (debug "make_objcompute varargctype=" (variadic_ctype 0))
		  (assert_msg "unexpected variable argument for make_objcompute" () (variadic_ctype 0)))
		))
     (debug "make_objcompute arglist=" arglist)
     (let ( (res
	     (instance  class_objcompute
			:obdi_destlist (make_list discr_list)
			:obcpt_expr (list_to_multiple arglist discr_multiple)
			:obcpt_type ctyp
			:obi_loc loc))
	    )
       (debug "make_objcompute res=" res)
       (return res)
       )))


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; variadic function to make an objexpandpureval out of a macrostring
 (defun make_objexpandpureval (loc ctyp comm :rest)
   (debug "make_objexpandpureval loc=" loc " ctyp=" ctyp " comm=" comm)
   (assert_msg "make_objexpandpureval check loc" (or (null loc) (is_a loc discr_mixed_location)) loc)
   (assert_msg "make_objexpandpureval check ctyp" (is_a ctyp class_ctype) ctyp)
   (assert_msg "make_objexpandpureval check comm" (or (null comm) (is_string comm)) comm)
   (when (== ctyp ctype_void)
       (warning_plain loc "bizarre :void ctype for pure expanded cvalue")
       (shortbacktrace_dbg "make_objexpandpureval void" 15))
   (let ( (arglist (make_list discr_list)) 
	  )
     (forever 
      argloop
      (variadic ( () 
		  (exit argloop))
		( (:long l)
		  (let ( (bl (make_integerbox discr_constant_integer l))
			 )
		    (list_append arglist bl)))
		( (:cstring s)
		  (let ( (bs (make_stringconst discr_verbatim_string s)) 
			 )
		    (list_append arglist bs)))
		( (:value v)
		  (cond ( (is_list v)
			  (list_append2list arglist v))
			( (is_multiple v)
			  (foreach_in_multiple
			   (v)
			   (curcomp :long ix)
			   (list_append arglist curcomp)))
			(:else
			 (list_append arglist v))))
		( :else
		  (debug "make_objexpandpureval varargctype=" (variadic_ctype 0))
		  (assert_msg "unexpected variable argument for make_objexpandpureval" ()))
		))
     (debug "make_objexpandpureval arglist=" arglist)
     (let ( (res
	     (instance  class_objexpandpureval
			:obv_type ctyp
			:oxpurval_loc loc
			:oxpurval_comm comm
			:oxpurval_cont (list_to_multiple arglist discr_multiple)))
	    )
       (debug "make_objexpandpureval res=" res)
       (return res)
       )))


 ;;;; selector to generate the declaration of an initial
 ;;; receiver some objinielem
 ;;; argument strbuf
 (defselector output_c_declinit class_selector
   :doc #{$OUTPUT_C_DECLINIT is the selector to generate the
 declaration of some initial element $RECV into the string-buffer
 $SBUF.}#
   :formals (recv sbuf)
   )
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; selector to put a destination into an objcode
 ;;; receiver: the objcode
 ;;; argument: the destination value
 ;;; result: the (modified) receiving objcode or its replacement
 (defselector put_objdest class_selector
   )

 ;;; selector to generate the c code for an object
 ;;; receiver: the object to output
 ;;; arguments: 
 ;;;; * DECLBUF the stringbuffer for the declarations
 ;;;; * IMPLBUF the stringbuffer for implementations
 ;;;; * DEPTH an unboxed integer for indentation...
 ;;; result is not used

 (defselector output_c_code class_selector
   :doc #{$OUTPUT_C_CODE is the selector to generate C code. $RECV is
   the receiver, $DECLBUF is the string-buffer for declarations,
   $IMPLBUF is the string-buffer for implementations, $DEPTH is the raw
   integer depth.}#
   :formals (recv declbuf implbuf :long depth)
   )

 ;;;; selector to generate the initial fill of some objinit
 ;;; receiver some objinitelem
 ;;; argument a stringbuffer
 (defselector output_c_initial_fill class_selector
   :doc #{$OUTPUT_C_INITIAL_FILL is the selector to generate the filling of
   some initalized object $RECV. $IMPLBUF is the string-buffer for
   implementations, $PTRSTR is the string value of the pointer to fill,
   and $DEPTH is the raw integer depth.}#
   :formals (recv implbuf ptrstr :long depth)
 )

 ;;;; selector to generate the predef fill of some objinit
 ;;; receiver some objinitelem
 ;;; argument a stringbuffer
 (defselector output_c_initial_predef class_selector
   :formals (recv sbuf prtrstr :long depth)
   )

 (export_values
  make_objexpandpureval 
  output_c_code
  output_c_declinit
  output_c_initial_fill
  output_c_initial_predef 
  put_objdest
  )

 ;; a catchall method for nrep-s (normal representations) each should
 ;; be separately compiled with its own method so this should never be
 ;; called
 (defun compilobj_catchall_nrep (recv gcx)
   (debug "compilobj_catchall_nrep recv=" recv " gcx=" gcx)
   (let ( (discr (discrim recv)) 
	  (discrname  (unsafe_get_field :named_name discr))
	  )
     (debug "compilobj_catchall_nrep discr=" discr)
     (errormsg_strv "{Internal Error} COMPILE_OBJ sent to unexpected object of class" discrname)
     (assert_msg "@@compile_obj should be implemented in nrep-s subclasses" () recv)
 ))
 (install_method class_nrep compile_obj compilobj_catchall_nrep)

 (defun putobjdest_catchall_objcode (recv desto)
   (debug "putobjdest_catchall_objcode recv=" recv " desto=" desto)
   (let ( (discr (discrim recv)) 
	  (discrname  (unsafe_get_field :named_name discr))
	  )
     (error_at () "PUT_OBJDEST sent to unexpected C-generated object $1 of class $2 for destination $3." 
	       recv discrname desto)
     (assert_msg "@@put_objdest should be implemented in generated c code subclasses" () recv discr)
     ))
 (install_method class_generated_c_code put_objdest putobjdest_catchall_objcode)


(defun putobjdest_catch_objputmodvar (recv desto)
  (debug "putobjdest_catch_objputmodvar recv=" recv " desto=" desto)
  (assert_msg "check recv" (is_a recv class_objputmodvar) recv desto)
  (let ( (loc (get_field :obi_loc recv))
	 (obind (get_field :obputmodvar_bind recv))
	 (bindsymb (get_field :binder obind))
	 )
    (error_at loc "assignment of a module variable $1 don't have any result" bindsymb)
    (assert_msg "@@put_objdest on objputmodvar" () recv desto)
    (return)))
(install_method class_objputmodvar put_objdest putobjdest_catch_objputmodvar)

 (defun putobjdest_catchall_anydiscr (recv desto)
   (debug "putobjdest_catchall_anydiscr recv=" recv " desto=" desto)
   (outcstring_err "* putobjdest unimplemented receiver discriminant ")
   (let ( (discr (discrim recv)) 
	  (discrname  (unsafe_get_field :named_name discr))
	  )
     (error_at () "PUT_OBJDEST sent to unexpected reciever $1 of discriminant $2 for destination $3." 
	       recv discr desto)
   (assert_msg "@@ unexpected catchall putobjdest anydiscr" () recv)))
 (install_method discr_any_receiver put_objdest putobjdest_catchall_anydiscr)


 (defun getctype_objvalue (recv env)
   (assert_msg "check recv objvalue" (is_a recv class_objvalue) recv)
   (unsafe_get_field :obv_type recv))
 (install_method class_objvalue get_ctype getctype_objvalue)





 ;; nil are ctype_value
 (defun gectyp_objnil (recv env)  
   ctype_value)
 (install_method class_objnil get_ctype gectyp_objnil)


 ;; initstring-s are ctype_value
 (defun gectyp_objinitstring (recv env)
   (return ctype_value))
 (install_method class_objinitstring get_ctype gectyp_objinitstring)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; in the debug output routineobj-s make huge output, so print the detail only when at toplevel
 (defun dbgout_routineobj (self dbgi :long depth)
   (if (<=i depth 0)
       (dbgout_namedobject_method self dbgi 0)
     (dbgout_namedobject_method self dbgi 30))
   )
 (install_method class_routineobj dbg_output dbgout_routineobj)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; common put destination of objdestinstr....
 (defun putobjdest_objdestinstr (recv desto)
   (assert_msg "putobjdest_objdestinstr check recv" (is_a recv class_objdestinstr) recv)
   (debug "putobjdest_objdestinstr recv=" recv " desto=" desto)
   (let ( (destl (unsafe_get_field :obdi_destlist recv)) )
     (if (not (is_list destl))
	 (progn 
	   (setq destl (make_list discr_list))
	   (unsafe_put_fields recv :obdi_destlist destl)))
     (let ( (firstd (pair_head (list_first destl))) )
       (if (== firstd desto)
	   (return recv)
	 (progn
	   (list_append destl desto)
	   (return recv)
	   )))))
 (install_method class_objdestinstr put_objdest putobjdest_objdestinstr)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; notes about code generation
 ;;;
 ;;; in addition of the code structure generated by cold-melt we
 ;;; need to be able to import values (hence bindings) from a start
 ;;; environment which is the only argument given to the generated
 ;;; start routine of the module


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;







 ;; for some reason, final returns are sometimes putobjdest-ed - a NOP here
 (defun putobjdest_objfinalreturn (recv desto)
   (assert_msg "check recv" (is_a recv class_objfinalreturn) recv)
   recv
   )
 (install_method class_objfinalreturn put_objdest putobjdest_objfinalreturn)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; produce the verbatim string for of a variadic symbol with a given suffix
 (defun variadic_idstr (variadsym :cstring suffix)
   (match variadsym
	  (?(as_null)
	    (return ()))
	  (?(instance class_cloned_symbol
		      :named_name ?nvarnam
		      :csym_urank ?(integerbox_of ?nvarurank))
	    (assert_msg "check nvarnam" (is_string nvarnam) nvarnam)
	    (let ( (sbuf (make_strbuf discr_strbuf))
		   )
	      (add2sbuf_strconst sbuf "variad_")
	      (add2sbuf_cident sbuf nvarnam)
	      (add2sbuf_strconst sbuf "_c")
	      (add2sbuf_longdec sbuf nvarurank)
	      (add2sbuf_strconst sbuf suffix)
	      (strbuf2string discr_verbatim_string sbuf)
	      ))
	  (?(instance class_symbol
		      :named_name ?nvarnam)
	    (assert_msg "check nvarnam" (is_string nvarnam) nvarnam)
	    (let ( (sbuf (make_strbuf discr_strbuf))
		   )
	      (add2sbuf_strconst sbuf "variad_")
	      (add2sbuf_cident sbuf nvarnam)
	      (add2sbuf_strconst sbuf suffix)
	      (strbuf2string discr_verbatim_string sbuf)
	      ))
	  (?_
	   (debug "variadic_idstr bad variadsym=" variadsym)
	   (assert_msg "variadic_idstr bad variadsym" () variadsym)
	   ())))

 (defun variadic_index_idstr (variadsym)
   :doc #{Gives the verbatim string representing the index for variadic $VARIADSYM or else null.}# 
   (variadic_idstr variadsym "_ix"))

 (defun variadic_length_idstr (variadsym)
   :doc #{Gives the verbatim string representing the length for variadic $VARIADSYM or else null.}# 
   (variadic_idstr variadsym "_len"))




 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; compile a single hook
 (defun compile2obj_hook (nhook modctx compicache :long num)
   (debug "compile2obj_hook nhook=" nhook "\n.. modctx=" modctx
	  "\n.. compicache=" compicache "\n.. num=" num
	  "\n.. class_hookroutineobj=" class_hookroutineobj)
   (assert_msg "check nhook" (is_a nhook class_nrep_hookproc) nhook)
   (assert_msg "check compicache" (is_mapobject compicache) compicache)
   (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
   (let (
	 (loc (get_field :nrep_loc nhook))
	 (nbody (get_field :nproc_body nhook))
	 (nhookname (get_field :nrclop_name nhook))
	 (hookroutname (let (
			     (namsbuf (make_strbuf discr_strbuf)) 
			     )
			 (add2sbuf_strconst namsbuf "melthook_")
			 (add2sbuf_cident namsbuf nhookname)
			 (strbuf2string discr_verbatim_string namsbuf)
			 ))
	 (ninbinds (get_field :nrclop_argbindtuple nhook))
	 (noutbinds (get_field :nrhook_outb nhook))
	 (resctype (get_field :nrhook_ctype nhook))
	 (ndatahook (get_field :nrhook_datahook nhook))
	 (nclosvtup (get_field :ndhook_closv ndatahook))
	 (obodylist (make_list discr_list))
	 (oepiloglist (make_list discr_list))
	 (oinargs (make_multiple discr_multiple (multiple_length ninbinds)))
	 (ooutargs (make_multiple discr_multiple (multiple_length noutbinds)))
	 (odatarg (instance class_objcformal
			    :obv_type ctype_value
			    :oformal_name '"melthookdatap"
			    :oformal_proc nhook
			    :oformal_bind ()
			    :oformal_locv ()
			    ))
	 (hookrout (instance class_hookroutineobj
			     :named_name hookroutname
			     :obrout_proc nhook
			     :obrout_body obodylist
			     :obrout_nbval (make_integerbox discr_integer 0)
			     :obrout_nblong (make_integerbox discr_integer 0)
			     :obrout_others (make_list discr_list)
			     :obrout_cntciter (make_integerbox discr_integer 0)
			     :obrout_cntletrec (make_integerbox discr_integer 0)
			     :ohookrout_datarg odatarg
			     :ohookrout_inargs oinargs
			     :ohookrout_outargs ooutargs
			     :ohookrout_epilog oepiloglist
			     ))
	 (locmap (make_mapobject discr_map_objects 
				 (+i 30 (*i 3 (+i (multiple_length ninbinds)
						  (multiple_length noutbinds))))))
	 (gcx (instance class_c_generation_context
			:gncx_objrout hookrout
			:gncx_locmap locmap
			:gncx_freeptrlist (make_list discr_list)
			:gncx_freelonglist (make_list discr_list)
			:gncx_freeothermaps (make_mapobject discr_map_objects 20)
			:gncx_compicache compicache
			:gncx_modulcontext modctx
			:gncx_matchmap (make_mapobject discr_map_objects 40)
			))
	 )
     (debug "compile2obj_hook " nhookname " empty hookrout=" hookrout 
	    "\n nclosvtup=" nclosvtup)
     (debug "compile2obj_hook " nhookname " resctype=" resctype "\n.. gcx=" gcx)
     (assert_msg "check resctype" (is_a resctype class_ctype) resctype)
     (let ( (retloc (get_free_objloctyped gcx '_reshook_ resctype))
	    (hdataloc (get_free_objloctyped gcx '_hookdata_ ctype_value))
	    (ogetdata (make_objcompute loc ctype_value 
				       ##{/*hookgetdata*/ $ODATARG}#))
	    )
       (put_fields gcx :gncx_retloc retloc)
       (put_fields odatarg :oformal_locv hdataloc)
       (put_objdest ogetdata hdataloc)
       (list_append obodylist ogetdata)
       ;; handle the input arguments
       (debug "compile2obj_hook " nhookname " ninbinds=" ninbinds)
       (foreach_in_multiple
	(ninbinds)
	(curinbnd :long inix)
	(debug "compile2obj_hook " nhookname " curinbnd=" curinbnd "\n .. inix=" inix)
	(assert_msg "check curinbnd" (is_a curinbnd class_formal_binding) curinbnd)
	(let ( (syminb (get_field :binder curinbnd))
	       (ctypinb (get_field :fbind_type curinbnd))
	       (locinb (get_free_objloctyped gcx syminb ctypinb))
	       (incname (let ( (sbuf (make_strbuf discr_strbuf))
			       )
			  (add2out sbuf "meltinp" inix "_" (symbol_cname syminb))
			  (strbuf2string discr_verbatim_string sbuf)))
	       (incformal (instance class_objcformal
				    :obv_type ctypinb
				    :oformal_name incname
				    :oformal_proc nhook
				    :oformal_bind curinbnd
				    :oformal_locv locinb))
	       (ogetfarg (make_objcompute loc ctypinb
					  ##{/*gethookinput*/ $INCFORMAL}#))
	       )
	  (put_int incformal inix)
	  (put_objdest ogetfarg locinb)
	  (list_append obodylist ogetfarg)
	  (debug "compile2obj_hook " nhookname " incformal=" incformal "\n.. ogetfarg=" ogetfarg)
	  (multiple_put_nth oinargs inix incformal)
	  (mapobject_put locmap curinbnd locinb)
	  ))
       (debug "compile2obj_hook " nhookname " oinargs=" oinargs "\n.. locmap=" locmap)
       ;;
       ;; handle the output arguments
       (debug "compile2obj_hook " nhookname " noutbinds=" noutbinds)
       (foreach_in_multiple
	(noutbinds)
	(curoutbnd :long outix)
	(debug "compile2obj_hook " nhookname " curoutbnd=" curoutbnd "\n .. outix=" outix)
	(assert_msg "check curoutbnd" (is_a curoutbnd class_formal_binding) curoutbnd)
	(let ( (symoutb (get_field :binder curoutbnd))
	       (ctypoutb (get_field :fbind_type curoutbnd))
	       (locoutb (get_free_objloctyped gcx symoutb ctypoutb))
	       (outcname (let ( (sbuf (make_strbuf discr_strbuf))
				)
			   (add2out sbuf "meltoutp" outix "_" (symbol_cname symoutb))
			   (strbuf2string discr_verbatim_string sbuf)))
	       (outcformal (instance class_objcformal
				     :obv_type ctypoutb
				     :oformal_name outcname
				     :oformal_proc nhook
				     :oformal_bind curoutbnd
				     :oformal_locv locoutb))
	       )
	  (put_int outcformal outix)
	  (debug "compile2obj_hook " nhookname " outcformal=" outcformal)
	  (multiple_put_nth ooutargs outix outcformal)
	  (mapobject_put locmap curoutbnd locoutb)
	  )
	)
       ;;
       (debug "compile2obj_hook " nhookname " here obodylist=" obodylist)
       (debug "compile2obj_hook " nhookname " ooutargs=" ooutargs 
	      "\n.. nbody=" nbody "\n..locmap=" locmap)
       ;; associate the hook with its routine in the compiler cache
       (mapobject_put compicache nhook hookrout)
       (debug "compile2obj_hook " nhookname " updated compicache=" compicache
	      "\n.. for nhook=" nhook "\n.. hookrout=" hookrout)
       (shortbacktrace_dbg "compile2obj_hook updated compicache" 15)
       ;;
       ;; associate each closedvalue with its retrieval in the compicache
       (debug "compile2obj_hook " nhookname " handling closvtup=" nclosvtup "\n")
       (foreach_in_multiple
	(nclosvtup)
	(nclosv :long clix)
	(debug "compile2obj_hook " nhookname " clix#" clix " nclosv=" nclosv)
	(let ( (ofetchcdata (instance class_objhooknth
				      :obv_type ctype_value
				      :ohknth_hook hdataloc
				      :ohknth_off (constant_box clix)))
	       )
	  (debug "compile2obj_hook " nhookname " ofetchcdata=" ofetchcdata "\n.. for nclosv=" nclosv)
	  (mapobject_put compicache nclosv ofetchcdata)
	  (debug "compile2obj_hook" " updated compicache=" compicache
		 "\n.. for nclosv=" nclosv
		 "\n.. with ofetchcdata=" ofetchcdata)
	  )
	)
       (debug "compile2obj_hook " nhookname " again updated compicache=" compicache
	      "\n.. obodylist=" obodylist "\n")
	 )
       ;;
       ;; compile the body
       (debug "compile2obj_hook " nhookname " beforebody obodylist=" obodylist)
       (debug "compile2obj_hook " nhookname " gcx=" gcx "\n.. nbody=" nbody)
       (let ( (obody (compile_obj nbody gcx))
	      )
	 (debug "compile2obj_hook " nhookname " obody=" obody)
	 (list_append obodylist obody)
	 ;; forget the closed data
       (foreach_in_multiple
	(nclosvtup)
	(closv :long clix)
	(debug "compile2obj_hook " nhookname " forgetting closv=" closv)
	(mapobject_remove compicache closv)
	 )
	 (debug "compile2obj_hook " nhookname " after forgethookdata compicache=" compicache)
	 (debug "compile2obj_hook " nhookname " final obodylist=" obodylist "\n")
	 ;;
	 ;; set the output parameters in the epilog
	 (foreach_in_multiple
	  (ooutargs)
	  (curout :long outix)
	  (debug "compile2obj_hook " nhookname " curout=" curout "\n... outix=" outix)
	  (let (
		(outloc (get_field :oformal_locv curout))
		(ctypoutb (get_field :obv_type curout))
		(ofargout (instance class_objputoutarg
				    :obi_loc loc
				    :oboutarg_formal curout))
		)
	    (debug "compile2obj_hook " nhookname " ofargout=" ofargout)
	    (list_append oepiloglist ofargout)
	    ))
	 ;;
	 (debug "compile2obj_hook " nhookname "oepiloglist=" oepiloglist)
	 (debug "compile2obj_hook " nhookname " return hookrout=" hookrout)
	 (return hookrout))))



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; compile a single procedure
 (defun compile2obj_procedure (pro modctx compicache :long num)
   (debug "compile2obj_procedure pro=" pro "\n.. num=" num
	  "\n..start compicache=" compicache
	  "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n")
   (assert_msg "check pro" (is_a pro class_nrep_routproc) pro)
   (assert_msg "check compicache" (is_mapobject compicache) compicache)
   (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
   (shortbacktrace_dbg "compile2obj_procedure" 14)
   (let ( (namsbuf (make_strbuf discr_strbuf)) 
	  (routfunam ())
	  (restnam ())
	  (mofuncount  (get_field :mocx_funcount modctx))
	  (mofiles (get_field :mocx_filetuple modctx))
	  (:long funum (+i 1 (get_int mofuncount)))
	  )
     (if (is_a pro class_nrep_defunroutproc)
	 (put_int mofuncount funum))
     (add2sbuf_strconst namsbuf "meltrout_")
     (add2sbuf_longdec namsbuf num)
     (add2sbuf_strconst namsbuf "_")
     (add2sbuf_cident namsbuf (get_field :mocx_modulename modctx))
     (if (is_a pro class_nrep_routproc)
	 (let ( (pronam (get_field :nrclop_name pro)) 
		(nvariadic (unsafe_get_field :nrpro_variadic pro))
		)
	   (cond ( (is_a pronam class_symbol)
		   (setq routfunam (symbol_cname pronam))
		   (add2out namsbuf "_" routfunam))
		 ( (is_a pronam class_named)
		   (let ( (nambuf (make_strbuf discr_strbuf))
			  )
		     (add2sbuf_strconst nambuf "_")
		     (add2sbuf_cident nambuf
				      (unsafe_get_field :named_name pronam))
		     (setq routfunam (strbuf2string discr_verbatim_string
						    nambuf))
		     (add2out namsbuf "_nm" routfunam)))
		 ( (is_string pronam)
		   (add2sbuf_cident namsbuf pronam)))	  
	   (if nvariadic 
	       (setq restnam nvariadic))
	   ))
     (let ( 
	   (nbody (unsafe_get_field :nproc_body pro))
	   (nloc (unsafe_get_field :nrep_loc pro))
	   (nargb (if (is_a pro class_nrep_routproc) (get_field :nrclop_argbindtuple pro)))
	   (obodylist (make_list discr_list))
	   ;; the number 20 below is the ratio of number of functions
	   ;; per secondary generated C file. Change it carefully!  the
	   ;; offset 12 helps to make the first file less big, since it
	   ;; already contains the huge initialization functions. 
	   (:long filenum (/iraw (+i funum 12) 20))
	   (:long nbfiles (multiple_length mofiles))
	   (obrout (instance class_procroutineobj
			     :named_name (strbuf2string discr_string namsbuf)
			     :obrout_proc pro
			     :obrout_body obodylist
			     :obrout_nbval (make_integerbox discr_integer 0)
			     :obrout_nblong (make_integerbox discr_integer 0)
			     :obrout_others (make_list discr_list)
			     :obrout_cntciter (make_integerbox discr_integer 0)
			     :obrout_cntletrec (make_integerbox discr_integer 0)
			     :oprout_loc nloc
			     :oprout_funam routfunam
			     :oprout_filenum (make_integerbox discr_constant_integer filenum)
			     :oprout_restnam restnam
			     )) 
	   (locmap (make_mapobject discr_map_objects (+i 20 (*i 3 (multiple_length nargb)))))
	   (gcx (let ( (gx (instance class_c_generation_context
				     :gncx_objrout obrout
				     :gncx_locmap locmap
				     :gncx_freeptrlist (make_list discr_list)
				     :gncx_freelonglist (make_list discr_list)
				     :gncx_freeothermaps (make_mapobject discr_map_objects 20)
				     :gncx_compicache compicache
				     :gncx_modulcontext modctx
				     :gncx_matchmap (make_mapobject discr_map_objects 40)
				     ))
		       )
		  (debug "compile2obj_procedure gcx=" gx "\n.. pro=" pro)
		  gx))
	   (retloc 
	    (let ( (retl (get_free_objlocptr gcx '_retval_)) )
	      (unsafe_put_fields gcx :gncx_retloc retl)
	      retl))
	   (gtatup 
	    (multiple_map 
	     nargb
	     (lambda (bnd :long ix)
	       (assert_msg "check bnd" (is_a bnd class_formal_binding) bnd)
	       (let ( (bctyp (unsafe_get_field :fbind_type bnd)) 
		      (bnam (unsafe_get_field :binder bnd))
		      (oloc 
		       (cond ( (== bctyp ctype_value)
			       (get_free_objlocptr gcx bnam) )
			     ( (== bctyp ctype_long)
			       (get_free_objloclong gcx bnam) )
			     (:else
			      (get_free_objloctyped gcx bnam bctyp)))
		       ) 
		      (ogarg
		       (if restnam
			   (instance class_objgetargrest
				     :obi_loc nloc
				     :obarg_obloc oloc
				     :obarg_bind bnd
				     :obarg_rest restnam)
			 (instance class_objgetarg
				   :obi_loc nloc
				   :obarg_obloc oloc
				   :obarg_bind bnd)))
		      )
		 (if (and (<=i ix 0) (!= bctyp ctype_value))
		     (error_plain nloc "first argument of function should be a value"))
		 (debug "compile2obj_procedure formal bnd=" bnd " oloc=" oloc)
		 (mapobject_put locmap bnd oloc)
		 ogarg
		 ))
	     ))
	   )
 ;;; grow the file tuple if needed
       (if (>=i filenum nbfiles)
	   (let ( (:long newnbfiles (+i nbfiles (+i 2 (/iraw filenum 4))))
		  (newfiletup (make_multiple discr_multiple newnbfiles))
		  )
	     (put_fields modctx :mocx_filetuple newfiletup)
	     (foreach_in_multiple 
	      (mofiles)
	      (curfile :long curix)
	      (multiple_put_nth newfiletup curix curfile))
	     ))
       ;; associate the procedure with its objroutine in the compiler cache
       (mapobject_put compicache pro obrout)
       (put_fields obrout :oprout_getargs gtatup)
       (debug "compile2obj_procedure updated compicache=" compicache
	      "\n.. pro=" pro
	      "\n.. obrout=" obrout ".. nbody=" nbody)
       (shortbacktrace_dbg "compile2obj_procedure updated compicache" 15)
       (assert_msg "check nbody" (is_a nbody class_nrep) nbody)
       (if (is_a pro class_nrep_routproc)
	   (let ( (pthuls (unsafe_get_field :nrpro_thunklist pro)) )
	     (debug "compile2obj_procedure pthuls=" pthuls)
	     (foreach_pair_component_in_list
	      (pthuls)
	      (pthupair pthu) 
	      (debug "compile2obj_procedure pthu=" pthu)
	      (assert_msg "compile2obj_procedure check pthu" (is_closure pthu) pthu)
	      (pthu gcx)
	      (debug "compile2obj_procedure after pthu=" pthu "\n.. compicache=" compicache)
	      )
	     ))
       (let ( (obody (compile_obj nbody gcx)) 
	      )
	 (debug "compile2obj_procedure obody=" obody)
	 (list_append obodylist obody)
	 )
       (debug "compile2obj_procedure return obrout=" obrout)
       (return obrout)
       )))



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  the initial routine uses the initial system data ...
 (definstance initialsystemdata_objpredef class_objpredef
   :obv_type ctype_value
   :obpredef 'INITIAL_SYSTEM_DATA
   )

 (defun append_comment (ilist comstr iloc)
   (list_append ilist (instance class_objcommentinstr :obi_loc iloc :obci_comment comstr)))
 (defun append_commentconst (ilist :cstring comment :value iloc)
   (list_append ilist (instance class_objcommentinstr :obi_loc iloc :obci_comment (make_stringconst discr_string comment))))



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile the initial procedure into an object
(defun compile2obj_initproc (ipro modctx idata compicache procurmodenvlist)
   (debug "compile2obj_initproc ipro=" ipro 
	  "\n* modctx=" modctx "\n* compicache=" compicache
	  "\n* procurmodenvlist=" procurmodenvlist 
	  "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n"
	  )
   (shortbacktrace_dbg "compile2obj_initproc" 15)
   (assert_msg "check ipro" (is_a ipro class_nrep_initproc) ipro)
   (assert_msg "check idata" (is_list idata) idata)
   (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
   (assert_msg "check compicache" (is_mapobject compicache) compicache)
   (let ((locmap (make_mapobject discr_map_objects 50))
	 (importvalues (get_field :ninit_imports ipro))
	 (importexprs (get_field :ninit_importexprs ipro))
	 (oiniprolog (make_list discr_list))
	 (oinibody (make_list discr_list))
	 (modinienv (get_field :mocx_initialenv modctx))
	 (modnam  (get_field :mocx_modulename modctx))
	 (rawmodnam (clone_with_discriminant modnam discr_verbatim_string))
	 (listrestrout (make_list discr_list))
	 (oinitrout
	  (let ( (oi
		  (instance class_initial_module_routineobj
			    ;; Change the "melt_start_this_module" name with
			    ;; great care, it is known by the MELT runtime, and
			    ;; some functions of warmelt-outobj.melt are
			    ;; hardwiring it, e.g. thru emission of struct
			    ;; frame_melt_start_this_module_st or elsewhere.
			    :named_name '"melt_start_this_module"
			    :obrout_proc ipro
			    :obrout_body oinibody
			    :obrout_nbval (make_integerbox discr_integer 0)
			    :obrout_nblong (make_integerbox discr_integer 0)
			    :obrout_others (make_list discr_list)
			    :obrout_cntciter (make_integerbox discr_integer 0)
			    :obrout_cntletrec (make_integerbox discr_integer 0)
			    :oirout_fill (make_list discr_list)
			    :oirout_prolog oiniprolog
			    :oirout_modctx modctx
			    )) )
	    (debug "compile2obj_initproc oinitrout=" oi)
	    oi))
	 (importmap (make_mapobject discr_map_objects 50))
	 (gcx
	  (let ( (gx (instance 
		      class_initial_generation_context
		      :gncx_objrout oinitrout
		      :gncx_locmap locmap
		      :gncx_freeptrlist (make_list discr_list)
		      :gncx_freelonglist (make_list discr_list)
		      :gncx_freeothermaps (make_mapobject discr_map_objects 20)
		      :gncx_compicache compicache
		      :gncx_modulcontext modctx
		      :gncx_matchmap (make_mapobject discr_map_objects 60)
		      :igncx_procurmodenvlist
		      (list_map 
		       procurmodenvlist
		       (lambda (curpro)
			 (debug "compile2obj_initproc procurmodenvlist curpro=" curpro)
			 (let ( (curou (mapobject_get compicache curpro)) )
			   (debug "compile2obj_initproc procurmodenvlist curou=" curou)
			   (assert_msg "check curou" (is_object curou) curou)
			   curou)))
		      ;; perhaps we should store not a list of procedures, but their matching routines
		      :igncx_importmap importmap
		      ))
		 )
	    (debug "compile2obj_initproc gcx=" gx)
	    gx))
	 (retinit 
	  (let ( (reti (get_free_objlocptr gcx '_retinit_)) )
	    (unsafe_put_fields gcx :gncx_retloc reti)
	    (unsafe_put_fields oinitrout :obrout_retval reti)
	    reti))
	 (boxloc
	  (let ( (boxl (get_free_objlocptr gcx '_contenv_)) )
	    (put_fields gcx :igncx_contenvloc boxl)
	    boxl))
	 (ofreshenv  (get_free_objlocptr gcx '_freshenv_))
	 (oprevenv  (let ( (preve (get_free_objlocptr gcx '_prevenv_))
			   )
		      (put_fields gcx :igncx_prevenvloc preve)
		      preve))
	 (inidefbinds (get_field :ninit_defbinds ipro))
	 )
     (append_commentconst oinibody "start of oinibody")
     (debug boxloc "compile2obj_initproc boxloc=" boxloc " inidefbinds=" inidefbinds)
;;; reserve location for defined values
     (foreach_pair_component_in_list
      (inidefbinds)
      (curpair curdefbind)
      (debug "compile2obj_initproc curdefbind=" curdefbind
	     " of discrim=" (discrim curdefbind))
      (let ( (inidefsymb (get_field :binder curdefbind))
	     (oinisym (get_field :fixbind_data curdefbind))
	     (oinidefloc (get_free_objlocptr gcx inidefsymb))
	     )
	(debug "compile2obj_initproc oinidefloc=" oinidefloc " oinisym=" oinisym
	       " of discrim:" (discrim oinisym)
	       " curdefbind=" curdefbind)
	;;oinisym is often a class_nrep_locsymocc but can be a
	;;class_nrep_defined_constant
	(assert_msg "check oinisym" (is_a oinisym class_nrep_simple) oinisym)
	(mapobject_put locmap curdefbind oinidefloc)
	))
     (debug "compile2obj_initproc" " importvalues=" importvalues)
     ;; create a commentedblock to compute the new environemnt box in boxloc if it is null 
     (let (
	   ;; cond to test boxloc & call the hook_fresh_environment_reference_maker if it if null

	   (otestcomputboxloc 
	    (instance
	     class_objcond
	     :obcond_test boxloc
	     :obcond_then ()
	     :obcond_else
	     (make_objcompute
	      ()
	      ctype_void
	      ##{ /* compile2obj_initproc emitted initialization of environment reference for $RAWMODNAM */
	      if ($OPREVENV) 
	        {
	          $BOXLOC = melthookproc_HOOK_FRESH_ENVIRONMENT_REFERENCE_MAKER 
	                         ((melt_ptr_t) $OPREVENV, "$RAWMODNAM") ;
	        }
	      else /* no prevenv */
	        {
#if MELT_HAS_INITIAL_ENVIRONMENT>0
	      if (!melt_flag_bootstrapping)
	        warning(0, "MELT is not creating a fresh environment reference for $RAWMODNAM without parent env.") ;
#endif /* MELT_HAS_INITIAL_ENVIRONMENT>0 */
	      }
	      }#
	      )))
	   ;;
	   (limplocv
	    (list_map 
	     importvalues
	     (lambda (ival)
	       (debug "compile2obj_initproc imported ival=" ival)
	       (assert_msg "check ival" (is_a ival class_nrep_importedval) ival)
	       (let ( (isym (unsafe_get_field :nimport_symb ival)) 
		      (ilocv (get_free_objlocptr gcx isym))
		      )
		 (debug "compile2obj_initproc imported ilocv=" ilocv)
		 (mapobject_put importmap isym ilocv)
		 ilocv
		 ))))
	   )
       (debug "compile2obj_initproc otestcomputboxloc=" otestcomputboxloc 
	      "\n.. importvalues=" importvalues
	      "\n.. limplocv=" limplocv)
       ;; the prologue starts by getting the previous environment from the
       ;; modargp_ unique argument
       (let ( (lisdest (make_list discr_list)) )
	 (list_append lisdest oprevenv)
	 (append_commentconst oiniprolog "get previous environment")
	 (list_append oiniprolog
		      (instance class_objcompute
				:obdi_destlist lisdest
				:obcpt_type ctype_value
				:obcpt_expr (make_stringconst discr_verbatim_string "/*getprevenv*/ (melt_ptr_t) modargp_"))
		      )
	 )
       (append_commentconst oiniprolog "compute boxloc")
       ;; we compute the boxloc at first
       (list_append oiniprolog otestcomputboxloc)
       ;; the tuple to compile the body
       (debug "compile2obj_initproc" " idata=" idata)
       (let (
	     (odatatup 
	      (list_to_multiple
	       idata discr_multiple
	       (lambda (curdat)
		 (debug "compile2obj_initproc:lambdabody" " curdat=" curdat)
		 (assert_msg "check curdat" (is_a curdat class_nrep_bound_data) curdat)
		 (let ( (curobd (compile_obj curdat gcx)) )
		   (debug "compile2obj_initproc:lambdabody" " curobd=" curobd)
		   curobd))))
	     (toplis (unsafe_get_field :ninit_topl ipro)) 
	     )
	 (unsafe_put_fields oinitrout
			    :oirout_data odatatup)
	 (assert_msg "check toplis" (is_list_or_null toplis) toplis)
	 ;; compile the toplevels
	 (let ( (objtoplis 
		 (list_map
		  toplis
		  (lambda (curtop)
		    (let ( (otop (compile_obj curtop gcx)) )
		      (debug "compile2obj_initproc otop=" otop)
		      otop)))) 
		)
	   (debug "compile2obj_initproc objtoplis=" objtoplis "\n modinienv=" modinienv)
	   (cond 
	    ( (is_object modinienv)
	      ;; generate the getting of symbols & keywords
	      (append_commentconst oiniprolog "get symbols & keywords for initial procedure")
	      (foreach_in_multiple
	       (odatatup)
	       (curpdat :long curk) 
	       (if (is_a curpdat class_objinitobject)
		   (let ( (odat (unsafe_get_field :oie_data curpdat))
			  )
		     (debug "compile2obj_initproc getting curpdat=" curpdat)
		     (cond 
		      ;; first  check for keywords, since they are also symbols (so order is important)
		      ( (is_a odat class_nrep_datakeyword)
			(let ( (ogkw (instance class_objgetnamedkeyword
					       :obgnamed_iobj curpdat))
			       )
			  (list_append oiniprolog ogkw)
			  (debug "compile2obj_initproc added keyword getting ogkw=" ogkw)
			  ))
		      ( (is_a odat class_nrep_datasymbol)
			(let ( (ogsy (instance class_objgetnamedsymbol
					       :obgnamed_iobj curpdat))
			       )
			  (list_append oiniprolog ogsy)
			  (debug "compile2obj_initproc added symbol getting ogsy=" ogsy)
			  ))
		      ))))
	      ;;
	      ;; get the value importer if needed
	      (when (>i (list_length importvalues) 0)
		;; 
		(debug "compile2obj_initproc importexprs=" importexprs)
		(append_commentconst oiniprolog "before getting imported values thru hook")
		(let ( (:long nbimportexprs (multiple_length importexprs))
		       (oimportup (make_multiple discr_multiple nbimportexprs))
		       )
		  (foreach_in_multiple
		   (importexprs)
		   (curimpexp :long impix)
		   (debug "compile2obj_initproc curimpexp=" curimpexp " impix#" impix)
		   (let ( (ocurimp (compile_obj curimpexp gcx))
			  )
		     (debug "compile2obj_initproc ocurimp=" ocurimp)
		     (list_append oiniprolog ocurimp)
		  )))

		(append_commentconst oiniprolog "after getting imported values")
		)
	      )				;end if modinienv
	    ( (null modinienv)
	      ;; initial module, don't need to generate importer or
	      ;; symbol or keyword getter, but need to emit the check
	      ;; that the parent environment is null
	      (let ( 
		    (modulverbstr (clone_with_discriminant
				   (get_field :mocx_modulename modctx) 
				   discr_verbatim_string))
		    (ochecknopar
		     (make_objcompute
		      ()
		      ctype_void
		      ##{ /* initialization of initial module $MODULVERBSTR */
		      melt_assertmsg("initial module $MODULVERBSTR should have no parent",
				     modargp_ == NULL) ;
		      }#
		      ))
		    )
		(debug "compile2obj_initproc ochecknopar=" ochecknopar)
		(list_append oiniprolog ochecknopar)
		))
	    (:else
	     (debug "compile2obj_initproc unexpected modinienv=" modinienv)
	     (assert_msg "compile2obj_initproc impossible modinienv" () modinienv)
	     )
	    ) ;; end cond
	   ;;
	   ;; append the compiled toplevel
	   (append_commentconst oinibody "before toplevel body")
	   (each_component_in_list
	    objtoplis
	    curobjt
	    (list_append oinibody curobjt))
	   (append_commentconst oinibody "after toplevel body")
	   ;; we compute the boxloc again
	   (append_commentconst oinibody "compute boxloc again")
	   (list_append oinibody otestcomputboxloc)
	   (append_commentconst oinibody "intern symbols")
	   ;; generate interning of symbols & keywords
	   (multiple_every
	    odatatup
	    (lambda (curpdat :long curk) 
	      (if (is_a curpdat class_objinitobject)
		  (let ( (odat (unsafe_get_field :oie_data curpdat))
			 )
		    (debug "compile2obj_initproc interning curpdat=" curpdat)
		    (cond 
		     ;; first  check for keywords, since they are also symbols (so order is important)
		     ( (is_a odat class_nrep_datakeyword)
		       (let ( (oikw (instance class_objinternkeyword
					      :obintern_iobj curpdat))
			      )
			 (list_append oinibody oikw)
			 (debug "compile2obj_initproc added keyword interning oikw=" oikw)
			 ))
		     ( (is_a odat class_nrep_datasymbol)
		       (let ( (oisy (instance class_objinternsymbol
					      :obintern_iobj curpdat))
			      )
			 (list_append oinibody oisy)
			 (debug "compile2obj_initproc added symbol interning oisy=" oisy)
			 ))
		     )))))
	   )				;end of toplevels
	 (append_commentconst oinibody "set retinit from boxloc")
	 ;; emit setting the retinit from the boxloc
	 (let ( (osetretinit
		 (make_objcompute () ctype_value
				  ##{/* finalsetretinit */ melt_reference_value((melt_ptr_t)($BOXLOC))}#))
		)
	   (put_objdest osetretinit retinit)
	   (debug "compile2obj_initproc adding osetretinit=" osetretinit)
	   (list_append oinibody osetretinit))
;;; ending
	 (append_commentconst oinibody "end the initproc")
	 (debug "compile2obj_initproc" " final oinibody=" oinibody " gcx=" gcx " oinitrout=" oinitrout
		"\n.. listrestrout=" listrestrout)
	 (return oinitrout listrestrout)
	 ))))




 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; this function is similar to compile2obj_initproc but they are some differences
 ;; it compiles the initial routine for runtime evaluation
 (defun compile2obj_initextendproc (ipro modctx idata compicache procurmodenvlist)
   (debug "compile2obj_initextendproc ipro=" ipro 
	  "\n* modctx=" modctx "\n* idata=" idata "\n* compicache=" compicache
	  "\n* procurmodenvlist=" procurmodenvlist 
	  "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n"
	  )
   (shortbacktrace_dbg "compile2obj_initextendproc" 12)
   (assert_msg "check ipro" (is_a ipro class_nrep_initextendproc) ipro)
   (assert_msg "check idata" (is_list idata) idata)
   (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx)
   (assert_msg "check compicache" (is_mapobject compicache) compicache)
   (let ( (locmap (make_mapobject discr_map_objects 50))
	  (importvalues (get_field :ninit_imports ipro))
	  (importexprs (get_field :ninit_importexprs ipro))
	  (oiniprolog (make_list discr_list))
	  (oinibody (make_list discr_list))
	  (modenv (get_field :ninitextend_modenv ipro))
	  (nbody (let ( (nb (get_field :nproc_body ipro))
			)
		   (debug "compile2obj_initextendproc nbody=" nb)
		   nb))
	  (modname (get_field :mocx_modulename modctx))
	  (litvalist (get_field :morcx_litervalist modctx))
	  (oinitxrout 
	   (let ( (oi
		   (instance class_initial_extension_routineobj
			     ;; change carefully the name, since the runtime
			     ;; should know it, notably its
			     ;; meltgc_run_cc_extension function
			     :named_name '"melt_start_run_extension"
			     :obrout_proc ipro
			     :obrout_body oinibody
			     :obrout_nbval (make_integerbox discr_integer 0)
			     :obrout_nblong (make_integerbox discr_integer 0)
			     :obrout_others (make_list discr_list)
			     :obrout_cntciter (make_integerbox discr_integer 0)
			     :obrout_cntletrec (make_integerbox discr_integer 0)
			     :oirout_fill (make_list discr_list)
			     :oirout_prolog oiniprolog
			     :oirout_modctx modctx
			     ))
		  )
	     (debug "compile2obj_initextendproc oinitxrout=" oi)
	     oi))
	  (importmap (make_mapobject discr_map_objects 30))
	  (valoclist (make_list discr_list))
	  ;; running expressions are usually smaller
	  (gcx (instance 
		class_extension_generation_context
		:gncx_objrout oinitxrout
		:gncx_locmap locmap
		:gncx_freeptrlist (make_list discr_list)
		:gncx_freelonglist (make_list discr_list)
		:gncx_freeothermaps (make_mapobject discr_map_objects 10)
		:gncx_compicache compicache
		:gncx_modulcontext modctx
		:gncx_matchmap (make_mapobject discr_map_objects 20)
		:igncx_procurmodenvlist
		(list_map 
		 procurmodenvlist
		 (lambda (curpro)
		   (debug "compile2obj_initextendproc procurmodenvlist curpro=" curpro)
		   (let ( (curou (mapobject_get compicache curpro)) )
		     (debug "compile2obj_initextendproc procurmodenvlist curou=" curou)
		     (assert_msg "check curou" (is_object curou) curou)
		     curou)))
		;; perhaps we should store not a list of procedures, but their matching routines
		:igncx_importmap importmap
		:egncx_valoclist valoclist
		))
	  ;; reserve stack location for the return value
	  (retinit 
	   (let ( (reti (get_free_objlocptr gcx '_retruninit_)) )
	     (put_fields gcx :gncx_retloc reti)
	     (put_fields oinitxrout :obrout_retval reti)
	     (debug "compile2obj_initextendproc retinit=" reti)
	     reti))
	  ;; reserve stack location for the current environment box container
	  (ocurenvboxloc
	   (let ( (boxl (get_free_objlocptr gcx '_ocurenvboxloc_)) )
	     (put_fields gcx :igncx_contenvloc boxl)
	     (debug "compile2obj_initextendproc ocurenvboxloc=" boxl)
	     boxl))
	  ;; reserve stack location for the current environment
	  (ocurenvloc
	   (let ( (locl (get_free_objlocptr gcx '_ocurenvloc_)) )
	     (debug "compile2obj_initextendproc ocurenvloc=" locl)
	     locl))
	  ;; reserve stack location for the previous environment
	  (oprevenvloc
	   (let ( (boxl (get_free_objlocptr gcx '_prevenvloc_)) )
	     (put_fields gcx :igncx_prevenvloc boxl)
	     (debug "compile2obj_initextendproc oprevenvloc=" boxl)
	     boxl))
	  ;; reserve stack location for the tuple of literal values
	  (olitvaluetuploc
	   (let ( (boxl (get_free_objlocptr gcx '_olitvaluetuploc_)) )
	     (put_fields gcx :egncx_litvaltuploc boxl)
	     (debug "compile2obj_initextendproc olitvaluetuploc=" boxl)
	     boxl))
	  ;; We don't have any exporter, because all values stay
	  ;; defined in the current environment so are implicitly
	  ;; exported.
	  ;;
	  ;; We don't have any importer, because we use the value
	  ;; literal tuple instead.
	  ;;
	  ;; initial defined bindings
	  (inidefbinds (get_field :ninit_defbinds ipro))
	  )
     (append_commentconst oinibody "start of oinibody")
     (debug "compile2obj_initextendproc ocurenvboxloc=" ocurenvboxloc
	    "\n inidefbinds=" inidefbinds
	    "\n modenv=" modenv)
     (debug "compile2obj_initextendproc importvalues=" importvalues 
	    "\n.. importexprs=" importexprs)
     ;; we actually could import literal named values.
     ;;
     ;; reserve location for defined values
     (debug "compile2obj_initextendproc inidefbinds=" inidefbinds)
     (assert_msg "check inidefbinds=" (is_list_or_null inidefbinds) inidefbinds)
     (foreach_pair_component_in_list
      (inidefbinds)
      (curpair curdefbind)
      (debug "compile2obj_initextendproc curdefbind=" curdefbind
	     " of discrim=" (discrim curdefbind))
      (let ( (inidefsymb (get_field :binder curdefbind))
	     (oinisym (get_field :fixbind_data curdefbind))
	     (oinidefloc (get_free_objlocptr gcx inidefsymb))
	     )
	(debug "compile2obj_initextendproc oinidefloc=" oinidefloc " oinisym=" oinisym
	       " of discrim:" (discrim oinisym)
	       " curdefbind=" curdefbind)
	;;oinisym is often a class_nrep_locsymocc but can be a
	;;class_nrep_defined_constant
	(assert_msg "check oinisym" (is_a oinisym class_nrep_simple) oinisym)
	(mapobject_put locmap curdefbind oinidefloc)
	))
     (debug "compile2obj_initextendproc updated locmap=" locmap "\n.. importvalues=" importvalues)
     ;;
     (let (
	   (limplocv
	    (list_map 
	     importvalues
	     (lambda (ival)
	       (debug "compile2obj_initextendproc imported ival=" ival)
	       (assert_msg "check ival" (is_a ival class_nrep_literalnamedvalue) ival)
	       (let ( (isym (get_field :nlitval_symbol ival)) 
		      (regval (get_field :nlitval_regval ival))
		      (litloc (get_field :litv_loc regval))
		      (ilocv (or litloc 
				 (let ( (nloc (get_free_objlocptr gcx isym))
					)
				   (debug "compile2obj_initextendproc nloc=" nloc " for ival=" ival)
				   (mapobject_put importmap isym nloc)
				   (put_fields litloc :litv_loc nloc)
				   nloc)))
		      )
		 (debug "compile2obj_initextendproc imported ilocv=" ilocv " for isym=" isym)
		 ilocv
		 )))))
       (debug "compile2obj_initextendproc limplocv=" limplocv)
       (void)
       )
     ;;
     ;; the prologue start by getting the the current environment
     ;; reference and the raw value tuple
     (list_append oiniprolog
		  (make_objlocatedexp 
		   () ctype_void
		   ##{/*initextendproc get boxcurenv*/ $OCURENVBOXLOC
		   = meltarg_curenvbox_p ;}#
		   ))
     (debug "compile2obj_initextendproc litvalist=" litvalist)
     (let ( (:long nblitval (list_length litvalist))
	    (toplis (unsafe_get_field :ninit_topl ipro)) 
	    )
       (debug "compile2obj_initextendproc toplis=" toplis)
       (list_append oiniprolog
		    (make_objlocatedexp 
		     () ctype_void
		     ##{/*initextendproc get litvaluetup*/ $OLITVALUETUPLOC 
		     = meltarg_tuplitval_p ;
		     if (melt_multiple_length((melt_ptr_t) $OLITVALUETUPLOC) !=
					     $NBLITVAL)
		     melt_fatal_error ("bad runtime extension literal value tuple@%p in " 
				       $MODNAME ", wants $NBLITVAL components", 
				       (void*) $OLITVALUETUPLOC) ;
		     }#
		     ))
       (list_append oiniprolog
		    (instance class_objgetslot
			      :obdi_destlist (list ocurenvloc)
			      :ogetsl_obj ocurenvboxloc
			      :ogetsl_field referenced_value
			      ))
       (list_append oiniprolog
		    (instance class_objgetslot
			      :obdi_destlist (list oprevenvloc)
			      :ogetsl_obj ocurenvloc
			      :ogetsl_field env_prev
			      ))
       (debug "compile2obj_initextendproc before body oiniprolog=" oiniprolog
	      "\n idata=" idata)
       (debug "compile2obj_initextendproc again toplis=" toplis
	      "\n.. gcx=" debug_less gcx)
       (assert_msg "check toplis" (is_list_or_null toplis) toplis)
       ;; compile the toplevels
       (let ( (objtoplis 
	       (list_map
		toplis
		(lambda (curtop)
		  (debug "compile2obj_initextendproc curtop=" curtop)
		  (let ( (otop (compile_obj curtop gcx)) )
		    (debug "compile2obj_initextendproc otop=" otop)
		    otop)))) 
	      )
	 (debug "compile2obj_initextendproc objtoplis=" objtoplis)
	 ;; now handle the body
	 ;; the tuple to compile the body
	 (let (
	       (odatatup 
		(list_to_multiple
		 idata discr_multiple
		 (lambda (curdat)
		   (debug "compile2obj_initextendproc/lambdabody curdat=" curdat)
		   (assert_msg "check curdat" (is_a curdat class_nrep_bound_data) curdat)
		   (let ( (curobd (compile_obj curdat gcx)) )
		     (debug "compile2obj_initextendproc/lambdabody curobd=" curobd)		   
		     curobd))))
	       )
	   (debug "compile2obj_initextendproc odatatup=" odatatup "\n.. toplis=" toplis)
	   (put_fields oinitxrout
		       :oirout_data odatatup)
	   ;; generate the getting of symbols & keywords
	   (append_commentconst oiniprolog "get symbols & keywords for extension")
	   (assert_msg "check odatatup" (is_multiple_or_null odatatup) odatatup)
	   (foreach_in_multiple
	    (odatatup)
	    (curpdat :long curk) 
	    (if (is_a curpdat class_objinitobject)
		(let ( (odat (unsafe_get_field :oie_data curpdat))
		       )
		  (debug "compile2obj_initextendproc getting curpdat=" curpdat)
		  (cond 
		   ;; first  check for keywords, since they are also symbols (so order is important)
		   ( (is_a odat class_nrep_datakeyword)
		     (let ( (ogkw (instance class_objgetnamedkeyword
					    :obgnamed_iobj curpdat))
			    )
		       (list_append oiniprolog ogkw)
		       (debug "compile2obj_initextendproc added keyword getting ogkw=" ogkw)
		       ))
		   ( (is_a odat class_nrep_datasymbol)
		     (let ( (ogsy (instance class_objgetnamedsymbol
					    :obgnamed_iobj curpdat))
			    )
		       (list_append oiniprolog ogsy)
		       (debug "compile2obj_initextendproc added symbol getting ogsy=" ogsy)
		       ))
		   ))))
	   (debug "compile2obj_initextendproc before imports oiniprolog=" oiniprolog)
	   ;;
	   (when (>i (list_length importvalues) 0)
	     (append_commentconst oiniprolog "before getting imported values")
	     ;; generate the getting of imported values
	     (foreach_pair_component_in_list
	      (importvalues)
	      (curpairimp curimport)
	      (debug "compile2obj_initextendproc curimport=" curimport)
	      (assert_msg "check curimport" (is_a curimport  class_nrep_literalnamedvalue) curimport)
	      (compile_warning "the generated import should have a cstring")
	      (let ( (impsym (get_field :nlitval_symbol curimport)) 
		     (regval (get_field :nlitval_regval curimport))
		     (val (get_field :litv_value regval))
		     (modulstr (get_field :mocx_modulename modctx)) 
		     (oimplocv (mapobject_get importmap impsym))
		     )
		(debug "compile2obj_initextendproc impsym=" impsym "\n regval=" regval "\n oimplocv=" oimplocv)
		(let ( 
		      (:long litrank (get_int (get_field :litv_rank regval)))
		      (ogetlit (make_objcompute
				()
				ctype_value
				##{/* retrieve runtime literal value #$LITRANK */
				((melt_ptr_t) (((meltmultiple_ptr_t)$OLITVALUETUPLOC)->tabval[$LITRANK]))
				}#))
		      )
		  (put_objdest ogetlit oimplocv)
		  (debug "compile2obj_initextendproc/import val=" val
			 " regval=" regval
			 " ogetlit=" ogetlit)
		  (list_append oiniprolog ogetlit)
		  )))
	     (append_commentconst oiniprolog "after getting imported values")
	     )
	   ;; append the compiled toplevel
	   (append_commentconst oinibody "before toplevel body")
	   (debug "compile2obj_initextendproc objtoplis=" objtoplis)
	   (foreach_pair_component_in_list
	    (objtoplis)
	    (curpair curobjt)
	    (debug "compile2obj_initextendproc appendinf curobjt=" curobjt)
	    (list_append oinibody curobjt))
	   (debug "compile2obj_initextendproc updated oinibody=" oinibody)
	   (debug "compile2obj_initextendproc nbody=" nbody)
	   (foreach_pair_component_in_list 
	    (nbody)
	    (curnpair curninst)
	    (debug "compile2obj_initextendproc curninst=" curninst)
	    (if (is_not_a curninst class_nrep_routproc)
		(let ( (curobjb (compile_obj curninst gcx))
		       )
		  (debug "compile2obj_initextendproc curobjb=" curobjb)
		  (cond ( (null curobjb)
			  (debug "compile2obj_initextendproc skipping null curobjb=" curobjb)
			  (void)
			  )
			( (is_a curobjb class_objpurevalue)
			  (debug "compile2obj_initextendproc skipping pure curobjb=" curobjb)
			  (void)
			  )
			(:else
			 (debug "compile2obj_initextendproc appending curobjb=" curobjb)
			 (list_append oinibody curobjb)
			 (void)))
		  )))
	   ;;
	   (append_commentconst oinibody "after toplevel body")
	   (debug "compile2obj_initextendproc final oinibody=" oinibody)
	   ;;
	   (debug "compile2obj_initextendproc gives oinitxrout=" oinitxrout "\n")
	   (return oinitxrout)
	   )))))



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (export_values 
  compile2obj_hook
  compile2obj_initproc
  compile2obj_initextendproc
  compile2obj_procedure
  variadic_index_idstr
  variadic_length_idstr
  )

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;function to get a free local value pointer for some name
 ;; any free ptr is only reused for its offset. the objlocv is not reused...
 (defun get_free_objlocptr (gcx nam)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "get_free_objlocptr start nam=" nam)
   (shortbacktrace_dbg "get_free_objlocptr" 7)
   (let ( (orout (unsafe_get_field :gncx_objrout gcx))
	  (freeli (unsafe_get_field :gncx_freeptrlist gcx)) 
	  (pfree (list_pop_first freeli))
	  (:long off -1)
	  )
     (if (not (is_a orout class_routineobj))
	 (debug "get_free_objlocptr bad orout=" orout))
     (assert_msg "check orout" (is_a orout class_routineobj) orout)
     (if (is_a pfree  class_objlocv)
	 (let ( (offpfree (unsafe_get_field :obl_off pfree)) )
	   (debug "get_free_objlocptr pfree=" pfree)
	   (assert_msg "get_free_objlocptr check offpfree" (is_integerbox offpfree) offpfree)
	   ;; check that pfree has no objnum so was unused 
	   (assert_msg "check pfree not used" (not (get_int pfree)) pfree)
	   (setq off (get_int offpfree)))
       (let ( (nbvalorout (unsafe_get_field :obrout_nbval orout)) )
	 (setq off (get_int nbvalorout))
	 ))
     (assert_msg "check off" (>=i off 0) off)
     (let ( (nbvalbox (unsafe_get_field :obrout_nbval orout)) 
	    (:long nbval (get_int nbvalbox))  
	    (nambuf (make_strbuf discr_strbuf))
	    )
       (cond ( (is_a nam class_named)
	       (let ( (namstr (unsafe_get_field :named_name nam)) )
		 (add2sbuf_cident nambuf namstr)))
	     ( (is_string nam)
	       (add2sbuf_cident nambuf nam)))
       (add2sbuf_strconst nambuf "__V")
       (add2sbuf_longdec nambuf (+i nbval 1))
       (put_int nbvalbox (+i nbval 1))
       (let ( (namstr (strbuf2string discr_string nambuf))
	      (oldnbvalbox (make_integerbox discr_integer nbval))
	      (nloc (instance class_objlocv
			      :obv_type ctype_value
			      :obl_off (make_integerbox discr_integer off)
			      :obl_proc orout
			      :obl_cname namstr)) 
	      )
	 (debug "get_free_objlocptr" " new nloc" nloc "\n.. for nam=" nam)
	 (return nloc)
	 ))))



 ;;; function to get a free local long for some name
 (defun get_free_objloclong (gcx nam)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "get_free_objloclong start nam=" nam)
   ;(shortbacktrace_dbg "get_free_objloclong start" 12)
   (let ( (orout (unsafe_get_field :gncx_objrout gcx))
	  (freeli (unsafe_get_field :gncx_freelonglist gcx)) 
	  (pfree (list_pop_first freeli))
	  (:long off -1)
	  )
     (assert_msg "check orout" (is_a orout class_routineobj) orout)
     (if (is_a pfree  class_objlocv)
	 (let ( (offpfree (unsafe_get_field :obl_off pfree)) )
	   (debug "get_free_objloclong pfree" pfree)
	   (assert_msg "check offpfree" (is_integerbox offpfree) offpfree)
	   ;; check that pfree has no objnum so was unused 
	   (assert_msg "check pfree not used" (not (get_int pfree)) pfree)
	   (setq off (get_int offpfree)))
       (let ( (nblongorout (unsafe_get_field :obrout_nblong orout)) )
	 (assert_msg "check nblongorout" (is_integerbox nblongorout) nblongorout)
	 (setq off (get_int nblongorout))))
     (assert_msg "check off" (>=i off 0) off)
     (let ( (nblongbox (unsafe_get_field :obrout_nblong orout)) 
	    (:long nblong (get_int nblongbox))  
	    (nambuf (make_strbuf discr_strbuf))
	    )
       (cond ( (is_a nam class_named)
	       (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
	     ( (is_string nam)
	       (add2sbuf_cident nambuf nam))
	     )
       (add2sbuf_strconst nambuf "__L")
       (add2sbuf_longdec nambuf (+i nblong 1))
       (put_int nblongbox (+i nblong 1))
       (let ( (nloc (instance class_objlocv
			      :obv_type ctype_long
			      :obl_off (make_integerbox discr_integer off)
			      :obl_proc orout
			      :obl_cname (strbuf2string discr_string nambuf))) )
	 (debug "get_free_objloclong new nloc=" nloc)
	 (return nloc)
	 ))))

 ;;; function to get a free local otherstuff for some name and ctype
 (defun get_free_objloctyped (gcx nam ctyp)
   (debug "get_free_objloctyped nam=" nam " ctyp=" ctyp)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp)
   (cond ( (== ctyp ctype_long)
	   (return (get_free_objloclong gcx nam)))
	 ( (== ctyp ctype_value)
	   (return (get_free_objlocptr gcx nam)))
	 ;; return null for the void ctype
	 ( (== ctyp ctype_void)
	   (return ()))
	 (:else 
	  (debug "get_free_objloctyped otherctyp nam=" nam " ctyp=" ctyp)
	  ;(shortbacktrace_dbg "get_free_objloctyped otherctyp" 15)
	  (let ( (freemap (unsafe_get_field :gncx_freeothermaps gcx)) 
		 (orout (unsafe_get_field :gncx_objrout gcx))
		 (:long off -1)
		 )
	    (assert_msg "check freemap" (is_mapobject freemap) freemap)
	    (assert_msg "check orout" (is_a orout class_routineobj) orout)
	    (let ( (freeli (mapobject_get freemap ctyp)) )
	      (if (null freeli) 
		  (progn
		    (setq freeli (make_list discr_list))
		    (mapobject_put freemap ctyp freeli)))
	      (let ( (pfree (list_pop_first freeli)) )
		(if (is_a pfree  class_objlocv)
		    (progn 
		      (debug  "get_free_objloctyped pfree=" pfree)
		      (assert_msg "check pfree was unused" (not (get_int pfree)) pfree)
		      (setq off (get_int (unsafe_get_field :obl_off pfree)))
		      )
		  (setq off  (list_length (unsafe_get_field :obrout_others orout))))
		(let ( 
		      (nambuf (make_strbuf discr_strbuf)) 
		      (others (unsafe_get_field :obrout_others orout))
		      (:long nbothers (list_length others))
		      )
		  (assert_msg "check others" (is_list others) others)
		  (add2sbuf_strconst nambuf "loc_")
		  (add2sbuf_cident nambuf 
				   (get_field :named_name 
					      (get_field :ctype_keyword ctyp)))
		  (add2sbuf_strconst nambuf "__o")
		  (add2sbuf_longdec nambuf nbothers)
		  (let ( (nloc (instance class_objlocv
					 :obv_type ctyp
					 :obl_proc orout
					 :obl_off (make_integerbox discr_integer off)
					 :obl_cname (strbuf2string discr_string nambuf))) )
		    (debug  "get_free_objloctyped new nloc" nloc)
		    (list_append others nloc)
		    (return nloc)
		    )
		  )))))))




 ;; function to dispose, i.e. mark as free and reusable, an  objlocation
 (defun dispose_objloc (oldloc gcx)
   (debug "dispose_objloc start disposing oldloc=" oldloc)
   (shortbacktrace_dbg "dispose_objloc" 9)
   (assert_msg "check oldloc" (is_a oldloc class_objlocv) oldloc)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context))
   ;; the obl_proc iff it has already been freed
   (assert_msg "check used oldloc" (unsafe_get_field :obl_proc oldloc) oldloc)
   (let ( (oldcty (unsafe_get_field :obv_type oldloc)) )
     (assert_msg "check oldcty not void" (!= oldcty ctype_void) oldcty)
     (assert_msg "check oldcty is ctype" (is_a oldcty class_ctype) oldcty)
     (put_fields oldloc :obl_proc ())			;mark the objlocation as freed
     (debug "dispose_objloc freeing oldloc=" oldloc)
     (cond ( (== oldcty ctype_value)
	     (let  ( (freepl (unsafe_get_field :gncx_freeptrlist gcx)) )
	       (list_append freepl oldloc)))
	   ( (== oldcty ctype_long)
	     (let  ( (freenl (unsafe_get_field :gncx_freelonglist gcx)) )
	       (list_append freenl oldloc)))
	   (:else
	    (let ( (freemap (unsafe_get_field :gncx_freeothermaps gcx)) 
		   (orout (unsafe_get_field :gncx_objrout gcx))
		   )
	      (assert_msg "check freemap" (is_mapobject freemap) freemap)
	      (assert_msg "check orout" (is_a orout class_routineobj) orout)
	      (let ( (freeli (mapobject_get freemap oldcty)) )
		;; since we are freeing, freeli should exist
		(assert_msg "check freeli" (is_list freeli) freeli)
		(list_append freeli oldloc)))))
     (debug "dispose_objloc freed oldloc=" oldloc)
     ))

 ;; function to dispose, i.e. mark as free, a binding 
 (defun dispose_bnd_obj (bnd gcx)
   (debug "dispose_bnd_obj start bnd=" bnd)
   (assert_msg "check bnd" (is_a bnd class_any_binding) bnd)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (locmap (unsafe_get_field :gncx_locmap gcx))
	  (oldloc (mapobject_get locmap bnd)) 
	  )
     (debug "dispose_bnd_obj oldloc=" oldloc)
     (when (null oldloc)
	   ;; special hack to dispose a void let binding - return immediately in that case
	   (and (is_a bnd class_let_binding)
		(== (unsafe_get_field :letbind_type bnd) ctype_void)
		(return))
	   (debug "dispose_bnd_obj nulloldloc bnd=" bnd)
	   )
     (assert_msg "check oldloc" (is_a oldloc class_objlocv) oldloc)
     (dispose_objloc oldloc gcx)
     (mapobject_remove locmap bnd)
     (debug "dispose_bnd_obj end bnd=" bnd)
     ))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_chunk (nchk gcx)
   (debug "compilobj_nrep_chunk nchk=" nchk)
   (assert_msg "check nchk" (is_a nchk class_nrep_chunk) nchk)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc nchk))
	  (nexp (unsafe_get_field :nchunk_expansion nchk))
	  (noper (unsafe_get_field :nchunk_oper nchk))
	  (ntyp (unsafe_get_field :nexpr_ctyp nchk))
	  )
     (debug "compilobj_nrep_chunk nexp=" nexp)
     (assert_msg "check noper" (is_a noper class_named) noper)
     (assert_msg "check nexp" (is_multiple nexp) nexp)
     (assert_msg "check ntyp" (is_a ntyp class_ctype) ntyp)
     (let (  (otup (multiple_map
		    nexp
		    (lambda (comp :long ix)
		      (debug "compilobj_nrep_chunk comp=" comp " ix#" ix)
		      (if (== (discrim comp) discr_verbatim_string)
			  (progn
			    (debug "compilobj_nrep_chunk verbstring comp=" comp 
				   " ix#" ix)
			    (return comp)
			    )			   
			(let ( (ocomp (compile_obj comp gcx)) 
			       )
			  (debug "compilobj_nrep_chunk ocomp=" ocomp
				 " ix#" ix)
			  (return ocomp))))
		    ))
	     (oexp (if loc
		       (instance class_objlocatedexpv
				 :obv_type ntyp
				 :obx_cont otup
				 :obcx_loc loc
				 )
		     (instance class_objexpv
			       :obv_type ntyp
			       :obx_cont otup)
		     ))      
	     )
       (debug "compilobj_nrep_chunk otup=" otup)
       (assert_msg "check ntyp" (is_a ntyp class_ctype) ntyp)
       (debug "compilobj_nrep_chunk result oexp=" oexp)
       oexp)
     ))
 (install_method class_nrep_chunk compile_obj compilobj_nrep_chunk)


 ;;;;;;;;;;;;;;;;
 (defun getctype_typexpr (recv env)
   (assert_msg "check recv" (is_a recv class_nrep_typed_expression) recv)
    (unsafe_get_field :nexpr_ctyp recv))
 (install_method class_nrep_typed_expression get_ctype getctype_typexpr)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_nil (nilo gcx)
   (assert_msg "check nilo" (is_a nilo class_nrep_nil) nilo)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (obnil (instance class_objnil
			   :obv_type ctype_value)) )
     (return obnil))
   )

 (install_method class_nrep_nil compile_obj compilobj_nrep_nil)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_comment (ncomm gcx)
   (debug "compilobj_nrep_comment start ncomm=" ncomm)
   (assert_msg "check ncomm" (is_a ncomm class_nrep_comment) ncomm)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (coms (unsafe_get_field :ncomm_string ncomm))
	  (nloc (unsafe_get_field :nrep_loc ncomm))
	  (sbuf (make_strbuf discr_strbuf)) )
     (add2sbuf_strconst sbuf "/**!* ")
     (add2sbuf_ccomstring sbuf coms)
     (add2sbuf_strconst sbuf " *!**/")
     (let ( (ostr (strbuf2string discr_verbatim_string sbuf)) 
	    (res  (instance class_objcompute
			    :obi_loc nloc
			    :obdi_destlist ()
			    :obcpt_type ctype_void
			    :obcpt_expr ostr))
	    )  
       (debug "compilobj_nrep_comment ostr=" ostr " res=" res)
       (return res)
       )))
 (install_method class_nrep_comment compile_obj compilobj_nrep_comment)


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_locsymocc (lsyo gcx)
   (debug "compilobj_nrep_locsymocc begin lsyo=" lsyo)
   (assert_msg "check nchk" (is_a lsyo class_nrep_locsymocc) lsyo)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc lsyo))
	  (locmap (unsafe_get_field :gncx_locmap gcx))
	  (sym (unsafe_get_field :nocc_symb lsyo))
	  (oty (unsafe_get_field :nocc_ctyp lsyo))
	  (sbnd (unsafe_get_field :nocc_bind lsyo))
	  (ovar (mapobject_get locmap sbnd))
	  )
     (debug "compilobj_nrep_locsymocc sbnd=" sbnd " ovar=" ovar)
     (when (null sbnd)
       (debug "compilobj_nrep_locsymocc null sbnd lsyo=" lsyo " sym=" sym)
       (error_at loc "bad mistyped MELT symbol occurrence $1 of type $2" sym oty)
       (assert_msg "locsymocc without binding" () lsyo)
	   )
     (if (null ovar) 
	 (progn
	   (debug "compilobj locsymocc null ovar sbnd=" sbnd 
		  "\n.. locmap=" locmap 
		  "\n.. lsyo=" lsyo 
		  "\n.. gcx=" debug_less gcx)
	   (when (!= oty ctype_void)
	     (error_at loc "bad MELT symbol occurrence $1 of type $2" sym oty)
	     (assert_msg "compilobj_nrep_locsymocc null ovar without ctype_void" (== oty ctype_void) oty lsyo locmap))
	   )
       (assert_msg "compilobj_nrep_locsymocc check ovar"  (is_a ovar class_objlocv) ovar))
     (debug "compilobj_nrep_locsymocc end lsyo=" lsyo " gives ovar=" ovar)
     (return ovar)
     ))
 (install_method class_nrep_locsymocc compile_obj compilobj_nrep_locsymocc)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_closedocc (nclo gcx)
   (debug "compilobj_nrep_closedocc nclo=" nclo)
   (assert_msg "check nclo" (is_a nclo class_nrep_closedocc) nclo)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( 
	 (orout (unsafe_get_field :gncx_objrout gcx))
	 (osym (unsafe_get_field :nocc_symb nclo))
	 (obind (unsafe_get_field :nocc_bind nclo))
	 (cprocs (unsafe_get_field :ncloc_procs nclo))
	 (lastcproc (pair_head (list_last cprocs)))
	 (nloc (unsafe_get_field :nrep_loc nclo))
	 )
     (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc) lastcproc)
     (let ( (cloblis (get_field :nrclop_clobindlist lastcproc)) 
	    (:long clorank -1)
	    )
       (assert_msg "check cloblis" (is_list cloblis) cloblis)
       (let ( (curpair (list_first cloblis)) 
	      (:long curank 0)
	      )
	 (forever 
	  looplis
	  (if (not (is_pair curpair)) (exit looplis))
	  (let ( (curbind (pair_head curpair)) )
	    (if (== curbind obind)
		(progn
		  (setq clorank curank)
		  (exit looplis)))
	    (setq curpair (pair_tail curpair))
	    (setq curank (+i curank 1))
	    ))
	 (assert_msg "check good closed rank" (>=i clorank 0) clorank)
	 (let ( 
	       (nclotyp (unsafe_get_field :nocc_ctyp nclo))
	       (ocloccv 
		(instance class_objcloccv
			  :obv_type nclotyp
			  :obc_off (make_integerbox discr_integer
						    clorank)
			  :obc_proc lastcproc
			  :obc_name (unsafe_get_field :named_name osym)))
	       )
	   (assert_msg "check nclotyp" (is_a nclotyp class_ctype) nclotyp)
	   (debug "compilobj closedocc result ocloccv=" ocloccv)
	   ocloccv
	   )))))

 (install_method class_nrep_closedocc compile_obj compilobj_nrep_closedocc)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_constocc (ncnst gcx)
   (debug "compilobj_nrep_constocc ncnst=" ncnst)
   (assert_msg "check ncnst" (is_a ncnst class_nrep_constocc) ncnst)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( 
	 (orout (unsafe_get_field :gncx_objrout gcx))
	 (osym (unsafe_get_field :nocc_symb ncnst))
	 (cprocs (unsafe_get_field :ncloc_procs ncnst))
	 (lastcproc (pair_head (list_last cprocs)))
	 (nloc (unsafe_get_field :nrep_loc ncnst))
	 (cnstyp (unsafe_get_field :nocc_ctyp ncnst))
	 (nbind (unsafe_get_field :nocc_bind ncnst))
	 )
     (debug "compilobj_nrep_constocc lastcproc=" lastcproc "\n..cprocs=" cprocs "\n..nbind=" nbind 
	    "\n.. gcx=" debug_less gcx)
     (shortbacktrace_dbg "compilobj_nrep_constocc" 8)
     (assert_msg "check lastcproc" (is_a lastcproc class_nrep_anyproc) lastcproc ncnst)
     (assert_msg "check cnstyp" (== cnstyp ctype_value) cnstyp ncnst)
     (cond 
      ;; handle routine procedures
      ( (is_a lastcproc class_nrep_routproc)
	(let ( (cnstlis (get_field :nrclop_constlist lastcproc)) 
	       (:long cnstrank -1)
	       )
	  (assert_msg "check cnstlis" (is_list cnstlis) cnstlis)
	  (let ( (curpair (list_first cnstlis)) 
		 (:long curank 0)
		 )
	    (forever 
	     looplis
	     (if (not (is_pair curpair)) (exit looplis))
	     (let ( (curelem (pair_head curpair)) )
	       (if (== curelem ncnst)
		   (progn
		     (setq cnstrank curank)
		     (exit looplis)))
	       (setq curpair (pair_tail curpair))
	       (setq curank (+i curank 1))
	       ))
	    (assert_msg "check good const rank" (>=i cnstrank 0) cnstrank)
	    (let ( 
		  (oconstv 
		   (instance class_objconstv
			     :obv_type cnstyp
			     :obc_off (constant_box cnstrank)
			     :obc_proc lastcproc
			     :obc_name (unsafe_get_field :named_name osym))) )
	      (debug "compilobj_nrep_constocc result oconstv=" oconstv ";\n.. from ncnst=" ncnst)
	      (return oconstv)
	      ))))
      ;; handle hook routines
      ( (is_a lastcproc class_nrep_hookproc)
	(let ( (:long offhk -1)
	       (:long count 0)
	       (hclobindlist (get_field :nrclop_clobindlist lastcproc))
	       )
	  (debug "compilobj_nrep_constocc hook hclobindlist=" hclobindlist)
	  (foreach_pair_component_in_list
	   (hclobindlist)
	   (curpair curbind)
	   (assert_msg "check curbind" (is_a curbind class_any_binding) curbind)
	   (let ( (cursym (get_field :binder curbind))
		  )
	     (when (== cursym osym)
	       (setq curpair ())
	       (setq offhk count))
	     (setq count (+i count 1))
	     ))
	  (debug "compilobj_nrep_constocc offhk=" offhk)
	  (assert_msg "check offhk" (>=i offhk 0) offhk)
	  (let ( (ohkconstv (instance class_objclohookv
				      :obv_type cnstyp
				      :obc_off (constant_box offhk)
				      :obc_proc lastcproc
				      :obc_name (unsafe_get_field :named_name osym))) 
		 )
	    (debug "compilobj_nrep_constocc result ohkconstv=" ohkconstv ";\n.. from ncnst=" ncnst)
	    (return ohkconstv)
	    )))
      (:else
       (debug "compilobj_nrep_constocc invalid lastcproc=" lastcproc "\n.. for ncnst=" ncnst)
       (assert_msg "compilobj_nrep_constocc unexpected lastcproc" () lastcproc ncnst)
       ))))

 (install_method class_nrep_constocc compile_obj compilobj_nrep_constocc)



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_importedval (nsva gcx)
   (debug "compilobj_nrep_importedval nsva=" nsva " gcx=" gcx)
   (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx)
   (assert_msg "check nsva" (is_a nsva class_nrep_importedval) nsva)
   (let ( (var (unsafe_get_field :nimport_symb nsva))
	  (olocv (mapobject_get (unsafe_get_field :igncx_importmap gcx) var))
	  )
     (debug "compilobj_nrep_importedval result olocv=" olocv)
     (assert_msg "check var" (is_a var class_symbol) var)
     (assert_msg "check olocv" (is_a olocv class_objlocv) olocv)
     (return olocv)
     ))
 (install_method class_nrep_importedval compile_obj compilobj_nrep_importedval)


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_literalvalue (nlitv gcx)
   (debug "compilobj_nrep_literalvalue nlitv=" nlitv 
	  "\n of discrim=" (discrim nlitv)
	  "\n gcx=" gcx)
   (let ( (litregval (get_field  :nlitval_regval nlitv))
	  (litvrank (get_field :litv_rank litregval))
	  (olitup (get_field :egncx_litvaltuploc gcx))
	  (nloc (get_field :nrep_loc nlitv))
	  )
     (debug "compilobj_nrep_literalvalue litregval=" litregval
	    "\n litvrank=" litvrank
	    "\n olitup=" olitup)
     (assert_msg "check litregval" (is_a litregval class_literal_value) litregval)
     (assert_msg "check litvrank" (is_integerbox litvrank) litvrank)
     (assert_msg "check gcx" (is_a gcx class_extension_generation_context) gcx)
     (let ( (res (make_objexpandpureval 
		  nloc ctype_value
		  (string4out discr_verbatim_string ##{literal-value #$LITVRANK}#)
		  ##{/*comp.literalvalue*/ (melt_ptr_t) (((meltmultiple_ptr_t)$OLITUP)->tabval[$LITVRANK])}#))
	    )
       (debug "compilobj_nrep_literalvalue res=" res)
       (return res)
       )))

 (install_method class_nrep_literalvalue compile_obj compilobj_nrep_literalvalue)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_definedconstant (ndconst gcx)
   (debug "compilobj definedconstant ndconst=" ndconst " gcx=" gcx)
   (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx)
   (assert_msg "check ndconst" (is_a ndconst class_nrep_defined_constant) ndconst)
   (let ( (nsval (unsafe_get_field :nconst_sval ndconst))
	  (nloc (unsafe_get_field :nrep_loc ndconst))
	  (locmap (unsafe_get_field :gncx_locmap gcx))
	  (ndefbnd (unsafe_get_field :nconst_defbind ndconst))
	  (ovloc (mapobject_get locmap ndefbnd))
	  (nproc (unsafe_get_field :nconst_proc ndconst))
	  )
     (debug "compilobj definedconstant ndefbnd=" ndefbnd " nloc=" nloc " ovloc=" ovloc " nproc=" nproc)
     (assert_msg "compilobj definedconstant check ovloc" ovloc)
     (return ovloc)
     ))
 (install_method class_nrep_defined_constant compile_obj compilobj_nrep_definedconstant)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a quasiconstant
 (defun compilobj_nrep_quasiconstant (nconst gcx)
   (debug "compilobj quasiconstant nconst=" nconst)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (assert_msg "check nconst" (is_a nconst class_nrep_quasiconstant) nconst)
   (let ( (nloc (unsafe_get_field :nrep_loc nconst))
	  (sval (unsafe_get_field :nconst_sval nconst))
	  (data (unsafe_get_field :nconst_data nconst))
	  (proc (unsafe_get_field :nconst_proc nconst))
	  )
     (if (is_a proc class_nrep_routproc)
	 (let ( (constlist (get_field :nrclop_constlist proc)) 
		(curpair (list_first constlist))
		(:long coff -1)
		(:long curank 0)
		(nambuf (make_strbuf discr_strbuf))
		)
	   (forever 
	    constloop
	    (if (is_pair curpair)
		(let ((curconst (pair_head curpair)))
		  (if (== curconst data)
		      (progn
			(setq coff curank)
			(exit constloop)))
		  )
	      (exit constloop))
	    (setq curpair (pair_tail curpair))
	    (setq curank (+i curank 1))
	    )
	   (assert_msg "check coff" (>=i coff 0) coff)
	   (add2sbuf_strconst nambuf "konst_")
	   (add2sbuf_longdec nambuf coff)
	   (if (is_a sval class_named)
	       (progn
		 (add2sbuf_strconst nambuf "_")
		 (add2sbuf_cident nambuf (unsafe_get_field :named_name sval))
		 )
	     )
	   (let ( (constv 
		   (instance class_objconstv
			     :obv_type ctype_value
			     :obc_off (make_integerbox discr_integer coff)
			     :obc_proc proc
			     :obc_name (strbuf2string discr_string nambuf)
			     )) )
	     (debug "compilobj quasiconstant constv=" constv)
	     (return constv)
	     )
	   )
       (let ( (odata (compile_obj data gcx)) )
	 ;; not inside a proc, just return the compiled data
	 (debug "compilobj quasiconstant odata=" odata)
	 (return odata)
	 )
       )
     )
   )
 (install_method class_nrep_quasiconstant compile_obj compilobj_nrep_quasiconstant)

 (defun compilobj_nrep_quasiconst_current_module_environment_reference (nqcme gcx)
   (debug "compilobj_nrep_quasiconst_current_module_environment_reference start nqcme=" nqcme)
   (assert_msg "check nqme" (is_a nqcme class_nrep_quasiconst_current_module_environment_reference) nqcme)
   (let ( (onres (compilobj_nrep_quasiconstant nqcme gcx))
	  (scomm (unsafe_get_field :nqcmec_comment nqcme))
	  (str (let ( (sbuf (make_strbuf discr_strbuf)) )
		 (add2sbuf_strconst sbuf "/*quasi.cur.mod.env.ref ")
		 (add2sbuf_ccomstring sbuf scomm)
		 (add2sbuf_strconst sbuf "*/\n")
		 (strbuf2string discr_verbatim_string sbuf)
		 )
	       )
	  (olres (make_objlocatedexp 
		  (unsafe_get_field :nrep_loc nqcme)
		  ctype_value
		  str 
		  ##{ /* check quasi.cur.mod.env.ref $(obj_hash nqcme) */ 
                  ($ONRES)
		  }#))
	  )
     (debug "compilobj_nrep_quasiconstant_current_module_environment_reference result olres=" olres)
     (return olres)
     ))
 (install_method class_nrep_quasiconst_current_module_environment_reference compile_obj
		 compilobj_nrep_quasiconst_current_module_environment_reference)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a forever
 (defun compilobj_nrep_forever (nfor gcx)
   (debug "compilobj_nrep_forever nfor=" nfor)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (assert_msg "check nfor" (is_a nfor class_nrep_forever) nfor)
   (let ( (nloc (unsafe_get_field :nrep_loc nfor))
	  (nbind (unsafe_get_field :nforever_bind nfor))
	  (nbody (unsafe_get_field :nforever_body nfor))
	  (nres (unsafe_get_field :nforever_result nfor)) 
	  (oresv (get_free_objlocptr gcx nres))
	  )
     (assert_msg "check nbind" (is_a nbind class_label_binding) nbind)
     (debug "compilobj_nrep_forever oresv=" oresv)
     (assert_msg "check oresv" (is_a oresv class_objlocv) oresv)
     (unsafe_put_fields nbind :labind_res oresv)
     (assert_msg "check again nbind" (is_object nbind) nbind)
     (debug "compilobj_nrep_forever updated nbind=" nbind)
     (let ( (closy (unsafe_get_field :labind_clonsy nbind)) 
	    (bodyl (make_list discr_list))
	    (epilogl (make_list discr_list))
	    (oloop (instance class_objloop
			     :obi_loc nloc
			     :oblo_bodyl bodyl
			     :oblo_epil epilogl
			     :obloop_label closy
			     :obloop_resv oresv))
	    )
       (assert_msg "check closy" (is_a closy class_cloned_symbol) closy)
       (multiple_every
	nbody
	(lambda (ncomp :long ix)
	  (list_append bodyl (compile_obj ncomp gcx))))
       (debug "compilobj forever result oloop=" oloop)
       oloop
       )
     )  
   )
 (install_method class_nrep_forever compile_obj compilobj_nrep_forever)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile an exit
 (defun compilobj_nrep_exit (nexi gcx)
   (debug "compilobj_nrep_exit nexi=" nexi)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (assert_msg "check nexi" (is_a nexi class_nrep_exit) nexi)
   (let ( 
	 (nloc (unsafe_get_field :nrep_loc nexi))
	 (nbindx (unsafe_get_field :nexit_bind nexi))
	 (nval (unsafe_get_field :nexit_val nexi)) 
	 )
     (assert_msg "check nbindx" (is_a nbindx class_label_binding) nbindx)
     (let ( 
	   (inslist (make_list discr_list)) 
	   (epilist (make_list discr_list)) 
	   (destlist (make_list discr_list))
	   (oval (compile_obj nval gcx))
	   (bxres (unsafe_get_field :labind_res nbindx))
	   (obloc (instance class_objplainblock
			    :obi_loc nloc
			    :oblo_bodyl inslist
			    :oblo_epil epilist
			    ))
	   (obex (instance class_objexit
			   :obi_loc nloc
			   :obexit_label (unsafe_get_field :labind_clonsy nbindx)
			   )) 
	   (obcom (instance class_objcompute
			    :obi_loc nloc
			    :obdi_destlist destlist
			    :obcpt_type ctype_value
			    :obcpt_expr oval))
	   )
       (list_append inslist obcom)
       (list_append epilist obex)
       (list_append destlist bxres)
       (debug "compilobj_nrep_exit return obloc=" obloc)
       (return obloc)
       )))
 (install_method class_nrep_exit compile_obj compilobj_nrep_exit)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; compile an again
 (defun compilobj_nrep_again (nag gcx)
   (debug "compilobj_nrep_again nag=" nag)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (assert_msg "check nag" (is_a nag class_nrep_again) nag)
   (let ( 
	 (nloc (unsafe_get_field :nrep_loc nag))
	 (nlabind (unsafe_get_field :nagain_bind nag))
	 (oagain (instance class_objagain
			   :obi_loc nloc 
			   :obagain_label (get_field :labind_clonsy nlabind)
			   ))
	 )
     (assert_msg "check nlabind" (is_a nlabind class_label_binding) nlabind)
     (debug "compilobj_nrep_again return oagain=" oagain)
     (return oagain)
 ))
 (install_method class_nrep_again compile_obj compilobj_nrep_again)



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_discrany (anyv gcx)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   anyv
   )
 (install_method discr_any_receiver compile_obj compilobj_discrany)



 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_let (rlet gcx)
   (debug "compilobj_nrep_let initial rlet=" rlet)
   (assert_msg "check rlet" (is_a rlet class_nrep_let) rlet)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc rlet))
	  (bnds (unsafe_get_field :nlet_bindings rlet))
	  (bdy (unsafe_get_field :nlet_body rlet))
	  (locmap (unsafe_get_field :gncx_locmap gcx))
	  (obodl (make_list discr_list))
	  (oepil (make_list discr_list))
	  (oblock (instance class_objplainblock
			    :obi_loc loc
			    :oblo_bodyl obodl
			    :oblo_epil oepil))
	  )
     (debug "compilobj_nrep_let initial loc=" loc "\n.. bnds=" bnds 
	    "\n.. bdy=" bdy
	    "\n.. locmap=" locmap)
     (shortbacktrace_dbg "compilobj_nrep_let" 9)
     ;; for each normalexp in the bnds tuple
     ;; add the binding and the setting in the body and the clear in the epilogue
     (assert_msg "compilobj_nrep_let check bnds multiple" (is_multiple_or_null bnds) bnds)
     ;; iterate on normal bindings
     (foreach_in_multiple
      (bnds)
      (nlbnd :long bndix)
      (debug "compilobj_nrep_let current normbinding loc=" loc " nlbnd=" nlbnd " locmap=" locmap)
      (assert_msg "check nlbnd in compilobj_nrep_let" (is_a nlbnd class_normal_let_binding) nlbnd)
      (let ( (bder (unsafe_get_field :binder nlbnd))
	     (cty (unsafe_get_field :letbind_type nlbnd))
	     (nexp (unsafe_get_field :letbind_expr nlbnd))
	     (obva (get_free_objloctyped gcx bder cty))
	     )
	(debug "compilobj_nrep_let current normbinding obva=" obva "\n nexp=" nexp)
	(let ( (obnx (compile_obj nexp gcx)) )
	  (debug "compilobj_nrep_let current normbinding obnx=" obnx
		 "\n.. for nexp=" nexp "\n.. with obva=" obva)
	  (if (is_a nexp class_sexpr) 
	      (when (not (is_object obnx))
		    (debug "compilobj_nrep_let current normbinding faulty nexp=" nexp " obnx=" obnx)
		    (assert_msg "compilobj_nrep_let check obnx" (is_object obnx) obnx nexp)))
	  (cond
	   ( obva
	     ;; non void cty
	     (mapobject_put locmap nlbnd obva)
	     (debug "compilobj_nrep_let obnx=" obnx 
		    "\n nlbnd=" nlbnd 
		    "\n obva=" obva)
	     (let ( (obpd (put_objdest obnx obva)) 
		    (obmy (or obpd obnx))
		    )
	       (debug "compilobj_nrep_let current obpd=" obpd " obmy=" obmy)
	       (list_append obodl obmy)
	       ))
	    (:else
	      ;; obva is nil when cty is void type 
	      (debug "compilobj_nrep_let append obnx=" obnx)
	      (list_append obodl obnx)
	      ))
	  ;; add clearing of obva to epilogue part of oblock
	  (if obva 
	      (let ( (obcl (instance class_objclear
				     :obi_loc loc
				     :oclr_vloc obva)) 
		     )
		(list_append oepil obcl)
		)))))
     (debug "compilobj_nrep_let after iterate normbind loc=" loc 
	    "\n.. locmap=" locmap "\n.. oepil=" oepil)
     ;;
     ;; compile each body component
     (assert_msg "check bdy" (is_multiple_or_null bdy) bdy)
     (foreach_in_multiple
      (bdy)
      (bdycomp :long bdyix)
      (debug "compilobj_nrep_let body loc=" loc 
	     " bdycomp=" bdycomp " bdyix=" bdyix)
      (let ( (objcomp  (compile_obj bdycomp gcx)) 
	     )
	(debug "compilobj_nrep_let body objcomp=" objcomp)
	;; objcomp is null when compiling a locvar of ctype_void;
	;; this happens with primitive of :void type
	(if (null objcomp) 
	    (void)
	  (list_append obodl objcomp))))
     (debug "compilobj_nrep_let after iterate body loc=" loc)
     ;;
     ;; dispose each binding
     (debug "compilobj_nrep_let disposing bnds=" bnds "\n.. with bdy=" bdy
	    "\n.. obodl=" obodl "\n.. locmap=" locmap "\n... loc=" loc)
     ;; @@@??? perhaps we should avoid disposing the binding of the
     ;; last component of tuple bdy, if it is its locsymocc...
     (foreach_in_multiple
      (bnds)
      (obnd :long ix)
      (debug "compilobj_nrep_let dispose loc=" loc " obnd=" obnd " ix=" ix)
      (dispose_bnd_obj obnd gcx))
     (debug "compilobj_nrep_let done disposal bnds=" bnds "\n.. locmap=" locmap "\n... loc=" loc)
     (debug "compilobj_nrep_let final loc=" loc " locmap=" locmap " oblock=" oblock)
     (return oblock)			;return it
     ))

 (install_method class_nrep_let compile_obj compilobj_nrep_let)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; selector to compile the fill inside a letrec
 ;;; receiver: the normalized constructrive binding
 ;;; arguments: 
 ;;;; * GCX the code generation context
 ;;; result = the obj instruction or value

 (defselector compile_letrec_fill class_selector
   :doc #{The selector $COMPILE_LETREC_FILL is used to compile the fill
   for a $LETREC. The $RECV is usually a constructive binding. $OBVA is
   the object variable, and $OBODL is the list for the body, $GCX being
   the generation context. $SLOC is the source location.}#
   :formals (recv obva obodl gcx sloc)
   )
 (export_values compile_letrec_fill)

 (defun fail_compiletrecfill (recv obva obodl gcx sloc)
   (debug "fail_compiletrecfill recv=" recv " obva=" obva)
   (let ( (d (discrim recv)) )
     (error_strv sloc "unimplemented discriminant for compile_letrec_fill"
		 (get_field :named_name d))
     (assert_msg "fail_compiletrecfill unexpected" () recv)
 ))
 (install_method discr_any_receiver compile_letrec_fill fail_compiletrecfill)

 ;;;;;;;;;;;;;;;;
 ;; generate inside the body list the code for filling lambda in letrecs
 (defun compiletrec_lambda (recv obva obodl gcx sloc)
   (debug "compiletrec_lambda recv=" recv " obva=" obva)
   (assert_msg "check recv" (is_a recv class_normal_constructed_lambda_binding) recv)
   (assert_msg "check obva" (is_a obva class_objlocv) obva)
   (assert_msg "check obodl" (is_list obodl) obodl)
   (let ( (loc (or (get_field :nconsb_loc recv) sloc))
	  (nclosed (get_field :nlambdab_nclosed recv))
	  (nconstrout (get_field :nlambdab_constrout recv))
	  (otouch (instance class_objtouch
			    :obi_loc loc
			    :otouch_val obva
			    ))
	  (ocrout (compile_obj nconstrout gcx))
	  (oputrout (instance class_objputclosurout
			      :obi_loc loc
			      :opclor_clos obva
			      :opclor_rout ocrout
			      ))
	  )
     (debug "compiletrec_lambda oputrout=" oputrout)
     (list_append obodl oputrout)
     ;;
     (debug "compiletrec_lambda nclosed=" nclosed)
     (foreach_in_multiple 
      (nclosed) 
      (curclosed :long curix)
      (debug "compiletrec_lambda curclosed=" curclosed " curix=" curix)
      (let ( (oclosed (compile_obj curclosed gcx)) 
	     )
	(debug "compiletrec_lambda oclosed=" oclosed)
	(cond ( (or (is_not_a oclosed class_objpurevalue)
		    (is_a oclosed class_objinstr))
		(if (>i curix 0)
		    (list_append obodl otouch))
		(list_append obodl oclosed) 
		)
	      (:else
	       (debug "compiletrec_lambda ignored generated code oclosed=" oclosed))
	      )
	(let ( 	    
	      (oputclo (instance class_objputclosedv
				 :obi_loc loc
				 :opclov_clos obva
				 :opclov_off (make_integerbox discr_integer curix)
				 :opclov_cval oclosed
				 )) 
	      )
	  (debug "compiletrec_lambda oputclo=" oputclo)
	  (list_append obodl oputclo)
	  ))
      )
     (list_append obodl otouch)
     (debug "compiletrec_lambda final obodl=" obodl)
     ))
 (install_method class_normal_constructed_lambda_binding compile_letrec_fill compiletrec_lambda)



 ;; generate inside the body list the code for filling tuple in letrecs
 (defun compiletrec_tuple (recv obva obodl gcx sloc)
   (debug "compiletrec_tuple recv=" recv " obva=" obva)
   (assert_msg "check recv" (is_a recv class_normal_constructed_tuple_binding) recv)
   (assert_msg "check obva" (is_a obva class_objlocv) obva)
   (assert_msg "check obodl" (is_list obodl) obodl)
   (let ( (loc (or (get_field :nconsb_loc recv) sloc))
	  (ncomptup (get_field :ntupb_comp recv))
	  (otouch (instance class_objtouch
			    :obi_loc loc
			    :otouch_val obva
			    ))
	  )
     (debug "compiletrec_tuple ncomptup=" ncomptup)
     (foreach_in_multiple
      (ncomptup)
      (ncurcomp :long ix)
      (debug "compiletrec_tuple ncurcomp=" ncurcomp " ix=" ix)
      (let ( (ocomp (compile_obj ncurcomp gcx)) 
	     (oputn (instance class_objputuple
			      :obi_loc loc
			      :oputu_tupled obva
			      :oputu_offset (make_integerbox discr_integer ix)
			      :oputu_value ocomp
			      ))
	     )
	(debug "compiletrec_tuple ocomp=" ocomp)
	(cond ( (or (is_not_a ocomp class_objpurevalue)
		    (is_a ocomp class_objinstr))
		(list_append obodl otouch)
		(list_append obodl ocomp)
		)
	      (:else 
	       (debug "compiletrec_tuple ignored generated code ocomp=" ocomp))
	      )
	(list_append obodl oputn)
	))
     (list_append obodl otouch)
     (debug "compiletrec_tuple final obodl=" obodl)
     ))
 (install_method class_normal_constructed_tuple_binding compile_letrec_fill compiletrec_tuple)


 ;; generate inside the body list the code for filling pair in letrecs
 (defun compiletrec_pair (recv obva obodl gcx sloc)
   (debug "compiletrec_pair recv=" recv " obva=" obva)
   (assert_msg "check recv" (is_a recv class_normal_constructed_pair_binding) recv)
   (assert_msg "check obva" (is_a obva class_objlocv) obva)
   (assert_msg "check obodl" (is_list obodl) obodl)
   (let ( (loc (or (get_field :nconsb_loc recv) sloc))
	  (nhead (get_field :npairb_head recv))
	  (ntail (get_field :npairb_tail recv))
	  (ohead (compile_obj nhead gcx))
	  (otail (if ntail (compile_obj ntail gcx)))
	  (oputhead (instance class_objputpairhead
			      :obi_loc loc
			      :oputp_pair obva
			      :oputp_head ohead))
	  (oputtail (if otail (instance class_objputpairtail
					:obi_loc loc
					:oputp_pair obva
					:oputp_tail otail)))
	  (otouch (instance class_objtouch
			    :obi_loc loc
			    :otouch_val obva
			    ))
	  )
     (debug "compiletrec_pair nhead=" nhead " ohead=" ohead
	    " ntail=" ntail " otail=" otail)
     (if (or (is_not_a ohead class_objpurevalue) 
	     (is_a ohead class_objinstr))
	 (list_append obodl ohead)
       (debug "compiletrec_pair ohead ignored generated code ohead=" ohead))
     (if (and otail (or (is_not_a otail class_objpurevalue) 
			(is_a otail class_objinstr)))
	 (list_append obodl otail)
       (debug "compiletrec_pair otail ignored generated code otail=" otail))
     (list_append obodl oputhead)
     (if oputtail (list_append obodl oputtail))
     (list_append obodl otouch)
     ))
 (install_method class_normal_constructed_pair_binding compile_letrec_fill compiletrec_pair)

 ;; generate inside the body list the code for filling pair in letrecs
 (defun compiletrec_list (recv obva obodl gcx sloc)
   (debug "compiletrec_list recv=" recv " obva=" obva)
   (assert_msg "check recv" (is_a recv class_normal_constructed_list_binding) recv)
   (assert_msg "check obva" (is_a obva class_objlocv) obva)
   (assert_msg "check obodl" (is_list obodl) obodl)
   (let ( (loc (or (get_field :nconsb_loc recv) sloc))
	  (nfirst (get_field :nlistb_first recv))
	  (nlast (get_field :nlistb_last recv))
	  (ofirst (if nfirst (compile_obj nfirst gcx)))
	  (olast (if nlast (compile_obj nlast gcx)))
	  (oputl (if (or ofirst olast)
		     (instance class_objputlist
			       :obi_loc loc
			       :oputl_list obva
			       :oputl_first ofirst
			       :oputl_last olast
			       )))
	  (otouch (instance class_objtouch
			    :obi_loc loc
			    :otouch_val obva
			    ))
	  )
     (if (and ofirst (or (is_not_a ofirst class_objpurevalue) (is_a ofirst class_objinstr)))
	 (list_append obodl ofirst)
       (debug "compiletrec_list ignored generated code ofirst=" ofirst)
       )
     (if (and olast (or  (is_not_a olast class_objpurevalue)
			 (is_a olast class_objinstr)))
	 (list_append obodl olast)
       (debug "compiletrec_list olast ignored generated code olast=" olast)
       )
     (if oputl 
	 (progn 
	   (list_append obodl oputl)
	   (list_append obodl otouch)
	   ))
     ))
 (install_method class_normal_constructed_list_binding compile_letrec_fill compiletrec_list)


 ;; generate inside the body list the code for filling instance in letrecs
 (defun compiletrec_instance (recv obva obodl gcx sloc)
   (debug recv "compiletrec_instance recv=" recv " obva=" obva " obodl=" obodl)
   (assert_msg "check recv" (is_a recv class_normal_constructed_instance_binding) recv)
   (assert_msg "check obva" (is_a obva class_objlocv) obva)
   (assert_msg "check obodl" (is_list obodl) obodl)
   (let ( (loc (or (get_field :nconsb_loc recv) sloc))
	  (nslots (get_field :ninstb_slots recv))
	  (nclabind (get_field :ninstb_clabind recv))
	  (otouch (instance class_objtouch
			    :obi_loc loc
			    :otouch_val obva
			    ))
	  (clas (cond ( (is_a nclabind class_value_binding)
			(unsafe_get_field :vbind_value nclabind))
		      ( (is_a nclabind class_class_binding)
			(unsafe_get_field :cbind_class nclabind))
		      (:else
		       (debug "compiletrec_instance bad nclabind=" nclabind)
		       (assert_msg "unexpected class binding" () nclabind))))
	  (flds (get_field :class_fields clas))
	  )
     (debug "compiletrec_instance clas=" clas " nslots=" nslots)
     (assert_msg "check clas" (is_a clas class_class) clas)
     (foreach_in_multiple
      (nslots)
      (curnslot :long slix)
      (debug "compiletrec_instance curnslot=" curnslot " slix=" slix)
      (if curnslot
	  (let ( (curfld (multiple_nth flds slix)) 
		 (oslot (compile_obj curnslot gcx))
		 )
	    (debug "compiletrec_instance curfld=" curfld " oslot=" oslot)
	    (if (or (is_not_a oslot class_objpurevalue)
		    (is_a oslot class_objinstr))
		(progn
		  (if (>i slix 0) (list_append obodl otouch))
		  (list_append obodl oslot))
	      (debug "compiletrec_instance ignored generated code oslot=" oslot))
	    (let ( (oputs (instance class_objputslot
				    :obi_loc loc
				    :oslot_odata obva
				    :oslot_offset (make_integerbox discr_integer slix)
				    :oslot_field curfld
				    :oslot_value oslot))
		   )
	      (debug "compiletrec_instance oputs=" oputs)
	      (list_append obodl oputs)
	      )))) 
     (list_append obodl otouch)
     (debug "compiletrec_instance final obodl=" obodl)
     ))
 (install_method class_normal_constructed_instance_binding compile_letrec_fill compiletrec_instance)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; compile of LETREC
 (defun compilobj_nrep_letrec (rlet gcx)
   (debug "compilobj_nrep_letrec initial rlet=" rlet)
   (assert_msg "check rlet" (is_a rlet class_nrep_letrec) rlet)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc rlet))
	  (bnds (unsafe_get_field :nlet_bindings rlet))
	  (fillbnds (unsafe_get_field :nletrec_fill_bindings rlet))
	  (bodybnds (unsafe_get_field :nletrec_body_bindings rlet))
	  (:long nbbnds (multiple_length bnds))
	  (nlocsyms (unsafe_get_field :nletrec_locsyms rlet))
	  (:long nblocsym (multiple_length nlocsyms))
	  (tuploc (make_multiple discr_multiple nblocsym))
	  (nbdy (unsafe_get_field :nlet_body rlet))
	  (locmap (unsafe_get_field :gncx_locmap gcx))
	  (obodl (make_list discr_list))
	  (oepil (make_list discr_list))
	  (ofreelocs (make_list discr_list))
	  (obrout (get_field :gncx_objrout gcx))
	  (obcntletrec (get_field :obrout_cntletrec obrout))
	  (:long cntletrec (+i 1 (get_int obcntletrec)))
	  (oallstruct (make_multiple discr_multiple nbbnds))
	  (namstr 
	   (let ( (nambuf (make_strbuf discr_strbuf)) )
	     (add2sbuf_strconst nambuf "meltletrec_")
	     (add2sbuf_longdec nambuf cntletrec)
	     (strbuf2string discr_verbatim_string nambuf)
	     ))
	  (oblock (instance class_objmultiallocblock
			    :obi_loc loc
			    :oblo_bodyl obodl
			    :oblo_epil oepil
			    :omalblo_allstruct oallstruct
			    :omalblo_name namstr
			    ))
	  )
     (debug "compilobj_nrep_letrec initial loc=" loc "\n.. nlocsyms=" nlocsyms 
	    "\n.. fillbnds=" fillbnds "\n.. bodybnds=" bodybnds "\n locmap=" locmap)
     (assert_msg "check fillbnds is list" (is_list_or_null fillbnds) fillbnds)
     (assert_msg "check bodybnds is list" (is_list_or_null bodybnds) bodybnds)
     (put_int obcntletrec cntletrec)
     (debug "compilobj_nrep_letrec updated obcntletrec=" obcntletrec)
     (foreach_in_multiple
      (nlocsyms)
      (curlocsym :long symix)
      (debug "compilobj_nrep_letrec curlocsym=" curlocsym " symix=" symix)
      (assert_msg "check curlocsym" (is_a curlocsym class_nrep_locsymocc) curlocsym)
      (let ( (curobva (get_free_objloctyped gcx (get_field :nocc_symb curlocsym) ctype_value))
	     (ocurclear (instance class_objclear
				  :obi_loc loc
				  :oclr_vloc curobva))
	     (cursbnd (multiple_nth bnds symix))
	     )
	(debug "compilobj_nrep_letrec again curlocsym=" curlocsym 
	       " curobva=" curobva " cursbnd=" cursbnd " ocurclear=" ocurclear " symix=" symix)
	(multiple_put_nth tuploc symix curobva)
	(mapobject_put locmap cursbnd curobva)
	(list_append oepil ocurclear)
	(list_append ofreelocs curobva)
	)
      )
     ;;
     (debug "compilobj_nrep_letrec locmap=" locmap " oblock=" oblock " ofreelocs=" ofreelocs " bnds=" bnds)
     (foreach_in_multiple
      (bnds)
      (curbnd :long bndix)
      (debug "compilobj_nrep_letrec curbnd=" curbnd " bndix=" bndix)
      (let ( (obnd (compile_obj curbnd gcx)) 
	     )
	(debug "compilobj_nrep_letrec obnd=" obnd)
	(multiple_put_nth oallstruct bndix obnd)
	(list_append obodl obnd)
	(debug "compilobj_nrep_letrec updated obodl=" obodl)
	)
      )
     ;; 
     ;; maybe we should reserve the recobva before compiling nrecexp
     (debug "compilobj_nrep_letrec fillbnds" fillbnds)
     (assert_msg "check fillbnds" (is_list_or_null fillbnds) fillbnds)
     ;; first loop to reserve the recobva
     (foreach_pair_component_in_list
      (fillbnds)
      (curecpair curecbnd)
      (debug "compilobj_nrep_letrec  get_free_objloc curecbnd=" curecbnd)
      (assert_msg "check curecbnd" (is_a curecbnd class_normal_let_binding) curecbnd)
      (let ( (rbder (unsafe_get_field :binder curecbnd))
	     (rcty (unsafe_get_field :letbind_type curecbnd))
	     (rloc (unsafe_get_field :letbind_loc curecbnd))
	     (recobva (get_free_objloctyped gcx rbder rcty))
	     )
	(debug "compilobj_nrep_letrec current normbinding recobva=" recobva)
	;; recobva can be nil when rcty is :void
	(if recobva
	    (let (
		  (oreclear (instance class_objclear
				      :obi_loc (or rloc loc)
				      :oclr_vloc recobva
				      ))
		  )
	      (assert_msg "check recobva" (is_a recobva class_objlocv) recobva)
	      (mapobject_put locmap curecbnd recobva)
	      (debug "compilobj_nrep_letrec oreclear=" oreclear)
	      (list_append oepil oreclear)
	      (list_append ofreelocs recobva)
	      ))))
     (debug "compilobj_nrep_letrec again locmap=" locmap " ofreelocs=" ofreelocs " fillbnds=" fillbnds)
     ;;
     ;; loop to compile the fillbindings
     (foreach_pair_component_in_list
      (fillbnds)
      (curecpair curfilbnd)
      (debug "compilobj_nrep_letrec compil curfilbnd=" curfilbnd)
      (assert_msg "check curfilbnd" (is_a curfilbnd class_normal_let_binding) curfilbnd)
      (let ( (rbder (unsafe_get_field :binder curfilbnd))
	     (rcty (unsafe_get_field :letbind_type curfilbnd))
	     (nrecexp (unsafe_get_field :letbind_expr curfilbnd))
	     (recobva (mapobject_get locmap curfilbnd))
	     )
	(debug "compilobj_nrep_letrec current recbinding nrecexp=" nrecexp)
	(let ( (robnx (compile_obj nrecexp gcx)) 
	       (rnewob ())
	       )
	  (debug "compilobj_nrep_letrec robnx=" robnx)
	  (if recobva
	      (setq rnewob (put_objdest robnx recobva))
	    (setq rnewob robnx))
	  (debug "compilobj_nrep_letrec rnewob=" rnewob)
	  (if (or (is_not_a rnewob class_objpurevalue)
		  (is_a rnewob class_objinstr))
	      (list_append obodl rnewob)
	    (debug "compilobj_nrep_letrec ignored generated code rnewob=" rnewob)
	    )
	  ))
      )
 ;;;
      (debug "compilobj_nrep_letrec after fillbinding obodl=" obodl)
 ;;;
 ;;; generate the fill of the letrec-ed constructions
     (foreach_in_multiple
      (bnds)
      (curbnd :long bndix)
      (let ( (obva (multiple_nth tuploc bndix))
	     )
	(debug "compilobj_nrep_letrec again obva=" obva " curbnd=" curbnd " bndix=" bndix)
	(compile_letrec_fill curbnd obva obodl gcx loc)
	(debug "compilobj_nrep_letrec letrecfilled obodl=" obodl)
	))
     ;;
     (debug "compilobj_nrep_letrec oallstruct=" oallstruct " obodl=" obodl)
     ;; loop to compile the bodybindings
     (foreach_pair_component_in_list
      (bodybnds)
      (cubdypair curbdybnd)
      (debug "compilobj_nrep_letrec compil curbdybnd=" curbdybnd)
      (assert_msg "check curbdybnd" (is_a curbdybnd class_normal_let_binding) curbdybnd)
      (let ( (rbder (unsafe_get_field :binder curbdybnd))
	     (rcty (unsafe_get_field :letbind_type curbdybnd))
	     (nbdyexp (unsafe_get_field :letbind_expr curbdybnd))
	     (bdyobva (get_free_objloctyped gcx rbder rcty))
	     (rloc (unsafe_get_field :letbind_loc curbdybnd))
	     )
	(debug "compilobj_nrep_letrec body bdyobva="bdyobva " nbdyexp=" nbdyexp)
	(mapobject_put locmap curbdybnd bdyobva)
	(let ( (robnx (compile_obj nbdyexp gcx)) 
	       (rnewob ())
	       )
	  (if (and bdyobva rcty (!= rcty ctype_void))
	      (progn
		(list_append ofreelocs bdyobva)
		(setq rnewob (put_objdest robnx bdyobva))
		)
	    (setq rnewob robnx))
	  (debug "compilobj_nrep_letrec rnewob=" rnewob)
	  (if (or (is_not_a rnewob class_objpurevalue)
		  (is_a rnewob class_objinstr))
	      (list_append obodl rnewob)
	    (debug "compilobj_nrep_letrec ignored generated code rnewob=" rnewob)
	    )
	  ))
      )
     ;;
     ;; compile the body
     (debug  "compilobj_nrep_letrec nbdy=" nbdy)
     (assert_msg "check nbdy" (is_multiple_or_null nbdy) nbdy)
     (foreach_in_multiple
      (nbdy)
      (curbdy :long bdix)
      (debug "compilobj_nrep_letrec curbdy=" curbdy " bdix=" bdix)
      (let ( (ocurb (compile_obj curbdy gcx)) )
	(debug "compilobj_nrep_letrec ocurb=" ocurb)
	(list_append obodl ocurb)))
     (debug "compilobj_nrep_letrec final obodl=" obodl "\n.. ofreelocs=" ofreelocs)
     ;; should clear and free our objlocs...
     (foreach_pair_component_in_list
      (ofreelocs)
      (curlpair curlocva)
      (debug "compilobj_nrep_letrec disposing curlocva=" curlocva)
      (assert_msg "check curlocva" (is_a curlocva class_objlocv) curlocva)
      (let ( (oclear (instance class_objclear
			       :obi_loc loc
			       :oclr_vloc curlocva))
	     )
	(list_append oepil oclear)
	(debug "compilobj_nrep_letrec oclear=" oclear " \n..disposing curlocva=" curlocva)
	(dispose_objloc curlocva gcx)
	(debug "compilobj_nrep_letrec final oclear=" oclear)
	))
     ;;
     (debug "compilobj_nrep_letrec final oblock=" oblock "\n.. oallstruct= "oallstruct
	    "\n.. gcx=" gcx "\n")
     oblock
     ))
 (install_method class_nrep_letrec compile_obj compilobj_nrep_letrec)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 (defun compilobj_nrep_citeration (nciter gcx)
   (assert_msg "check nciter" (is_a nciter class_nrep_citeration) nciter)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_citeration nciter=" nciter)
   (let ( (loc (unsafe_get_field :nrep_loc nciter))
	  (obrout (unsafe_get_field :gncx_objrout gcx))
	  (citer (unsafe_get_field :nciter_citerator nciter))
	  (nlocbind (unsafe_get_field :nciter_locbindings nciter))
	  (nchkbef (unsafe_get_field :nciter_chunkbefore nciter))
	  (nstatocc (let ( (ns (unsafe_get_field :nciter_statocc nciter)) ) 
		      (debug "compilobj_nrep_citeration nstatocc=" ns)
		      (assert_msg "check nstatocc" (is_a ns class_nrep_locsymocc) ns)
		      ns))
	  (nbody (unsafe_get_field :nciter_body nciter))
	  (nbodbind (unsafe_get_field :nciter_bodbindings nciter))
	  (nchkaft (unsafe_get_field :nciter_chunkafter nciter))
	  (nstatbind (let ( (bi (unsafe_get_field :nocc_bind nstatocc)) )
		       (assert_msg "check nstatbind" (is_a bi class_normal_let_binding) bi)
		       bi))
	  (nstatsy (unsafe_get_field :binder nstatbind))
	  (ostat (get_free_objloctyped gcx nstatsy (unsafe_get_field :nocc_ctyp nstatocc)))
	  (obodl (make_list discr_list))
	  (oepil (make_list discr_list))
	  (ocblock (instance class_objciterblock
			     :obi_loc loc
			     :oblo_bodyl obodl
			     :oblo_epil oepil
			     :obciter_citer citer
			     :obciter_before ()
			     :obciter_after ()
			     ))
	  (locmap  (unsafe_get_field  :gncx_locmap gcx))
	  )
     (debug "compilobj_nrep_citeration ostat=" ostat " nlocbind=" nlocbind)
     (assert_msg "check citer" (is_a citer class_citerator) citer)
     (assert_msg "check locmap" (is_mapobject locmap) locmap)
     (assert_msg "check nlocbind" (is_multiple_or_null nlocbind) nlocbind)
     (multiple_every
      nlocbind
      (lambda (nlbnd :long ix)
	(debug "compilobj_nrep_citeration current nlocbinding nlbnd=" nlbnd " ix=" ix)
	(assert_msg "check nlbnd in compilobj_nrep_citeration" (is_a nlbnd class_normal_let_binding) nlbnd)
	(let ( (bder (unsafe_get_field :binder nlbnd))
	       (cty (unsafe_get_field :letbind_type nlbnd))
	       (nexp (unsafe_get_field :letbind_expr nlbnd))
	       (oblva (get_free_objloctyped gcx bder cty))
	       )
	  (debug "compilobj_nrep_citeration current local bder=" bder " oblva=" oblva)
	  (if (!= cty ctype_void)
	      (let ( (oclr (instance class_objclear
				     :obi_loc loc
				     :oclr_vloc oblva) ) )
		(list_append oepil oclr)
		(mapobject_put locmap nlbnd oblva)
		(debug "compilobj_nrep_citeration added clear for nlbnd=" nlbnd)
		))
	  )))
     (debug "compilobj_nrep_citeration start ocblock=" ocblock)
     (let ( (boxcntciter (unsafe_get_field :obrout_cntciter obrout))
	    (:long cnt (+i 1 (get_int boxcntciter)))
	    (statstr 
	     (let ( (sbu (make_strbuf discr_strbuf)) )
	       (put_int boxcntciter cnt)
	       (add2sbuf_strconst sbu "meltcit")
	       (add2sbuf_longdec sbu cnt)
	       (add2sbuf_strconst sbu "__")
	       (add2sbuf_cident sbu (unsafe_get_field :named_name nstatsy))
	       (strbuf2string discr_verbatim_string sbu)
	       ))
	    )
       (unsafe_put_fields 
	ocblock
	:obciter_before (multiple_map 
			 nchkbef 
			 (lambda (cbef :long ix)
			   (cond 
			    ((is_string cbef) cbef)
			    ((== cbef nstatocc) statstr)
			    (:else
			     (let ( (obef (compile_obj cbef gcx)) )
			       obef
			       )))))
	:obciter_after (multiple_map
			nchkaft 
			(lambda (caft :long ix)
			  (cond 
			   ((is_string caft) caft)
			   ((== caft nstatocc) statstr)
			   (:else
			    (let ( (oaft (compile_obj caft gcx)) )
			      oaft
			      )))))
	)
       )
     (debug "compilobj_nrep_citeration filled before&after chunks ocblock=" ocblock)
     (assert_msg "check nbodbind" (is_list_or_null nbodbind) nbodbind)
     (list_every
      nbodbind
      (lambda (nbbnd :long ix)
	(assert_msg "check nbbnd in compilobj_nrep_citeration" (is_a nbbnd class_normal_let_binding) nbbnd)
	(let ( (bder (unsafe_get_field :binder nbbnd))
	       (cty (unsafe_get_field :letbind_type nbbnd))
	       (nexp (unsafe_get_field :letbind_expr nbbnd))
	       (obbva (get_free_objloctyped gcx bder cty))
	       )
	  (if (!= cty ctype_void)
	      (let ( (oclr (instance class_objclear
				     :obi_loc loc
				     :oclr_vloc obbva)) 
		     )
		(list_append oepil oclr)
		(mapobject_put locmap nbbnd obbva)
		)
	    )
	  (let ( (ocur (compile_obj nexp gcx)) )
	    (if (!= cty ctype_void)
		(progn
		  (let ( (newocur (put_objdest ocur obbva)) )
		    (if newocur 
			(list_append obodl newocur)
		      (list_append obodl ocur))
		    ))
	      (progn
		(list_append obodl ocur)
		)))
	  )))
     (debug "compilobj_nrep_citeration nbody=" nbody)
     (multiple_every
      nbody
      (lambda (ncurbod :long ix)
	(let ( (ocbod (compile_obj ncurbod gcx)) )
	  (list_append obodl ocbod)
	  )))
     (debug "compilobj_nrep_citeration final ocblock=" ocblock)
     (return ocblock) 
     )
   )

 (install_method class_nrep_citeration compile_obj compilobj_nrep_citeration)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a setq
 (defun compilobj_nrep_setq (nsq gcx)
   (assert_msg "check nsq" (is_a nsq class_nrep_setq) nsq)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_setq nsq=" nsq)
   (let ( (loc (unsafe_get_field :nrep_loc nsq))
	  (var (unsafe_get_field :nstq_var nsq))
	  (exp (unsafe_get_field :nstq_exp nsq))
	  )
     (debug "compilobj_nrep_setq loc=" loc " var=" var " exp=" exp)
     (let (
	  (cexp (compile_obj exp gcx))
	  (cvar (compile_obj var gcx))
	  (cres (put_objdest cexp cvar))
	  )
     (debug "compilobj_nrep_setq loc=" loc " left var=" var " cvar=" cvar
	    "\n right exp=" exp " cexp=" cexp " cres=" cres)
     (and (is_a cres class_objinstr)
	  (null (unsafe_get_field :obi_loc cres))
	  (unsafe_put_fields cres :obi_loc loc))
     (debug "compilobj_nrep_setq cres=" cres)
     cres
     )))
 (install_method class_nrep_setq compile_obj compilobj_nrep_setq)


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a progn
 (defun compilobj_nrep_progn (npro gcx)
   (debug "compilobj_nrep_progn npro=" npro)
   (assert_msg "check npro" (is_a npro class_nrep_progn) npro)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc npro))
	  (nseq (unsafe_get_field :nprogn_seq npro))
	  (nlast (unsafe_get_field :nprogn_last npro))
	  (bodyl (make_list discr_list))
	  (oblock (instance class_objplainblock
			    :obi_loc loc
			    :oblo_bodyl bodyl
			    ;; :oblo_epil is left null
			    ))
	  )
     (debug "compilobj_nrep_progn nseq=" nseq)
     (foreach_in_multiple
      (nseq)
      (ncomp :long ix)
      (debug "compilobj_nrep_progn ncomp=" ncomp "\n ix#" ix "\n in npro=" npro)
      (let ( (ocomp (compile_obj ncomp gcx)) )
	(debug "compilobj_nrep_progn ocomp=" ocomp "\n ix#" ix)
	(list_append bodyl ocomp)
	))
     (debug "compilobj_nrep_progn nlast=" nlast)
     (let ( (olast (compile_obj nlast gcx)) )
	(debug "compilobj_nrep_progn olast=" olast)
       (list_append bodyl olast))
     ;;
     (debug "compilobj_nrep_progn return oblock=" oblock "\n from npro=" npro)
     (return oblock)
     ))
 (install_method class_nrep_progn compile_obj compilobj_nrep_progn)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a multacc [data multiple accessor]
 (defun compilobj_nrep_multacc (nma gcx)
   (assert_msg "check nma" (is_a nma class_nrep_multacc) nma)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_multacc nma=" nma)
   (let ( (loc (unsafe_get_field :nrep_loc nma))
	  (mul (unsafe_get_field :naccm_mul nma))
	  (ix (unsafe_get_field :naccm_ix nma))
	  (cmul (compile_obj mul gcx))
	  ;; we factor the case when the tuple access cannot be done at
	  ;; compile time
	  (makecompute 
	   (lambda ()
	     (let (
		   (tcont 
		    (tuple
		     (make_stringconst discr_verbatim_string "/*multacc*/(melt_multiple_nth((")
		     cmul
		     (make_stringconst discr_verbatim_string "), (")
		     ix
		     (make_stringconst discr_verbatim_string ")))")
		     ))
		   (res 
		    (instance class_objexpv
			      :obv_type ctype_value
			      :obx_cont tcont))
		   )
	       (debug "compilobj_nrep_multacc makecompute res=" res)
	       res
	       ))
	   )
	  )
     (debug "compilobj_nrep_multacc cmul=" cmul " nma=" nma)
     (if (and
	  (is_a cmul class_objinitmultiple)
	  (is_integerbox ix))
	 (let ( (comptup (unsafe_get_field :oim_tupval cmul)) )
	   (if (is_multiple comptup)
	       (let (
		     (curval (multiple_nth comptup (get_int ix))) 
		     )
		 (debug "compilobj_nrep_multacc returning curval=" curval)
		 (return curval)
		 )
	     (makecompute)
	     ))
       (makecompute)
       )))
 (install_method class_nrep_multacc compile_obj compilobj_nrep_multacc)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a fieldacc [data field accessor]
 (defun compilobj_nrep_fieldacc (nfa gcx)
   (assert_msg "check nfa" (is_a nfa class_nrep_fieldacc) nfa)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_fieldacc nfa=" nfa)
   (let ( (loc (unsafe_get_field :nrep_loc nfa))
	  (obj (unsafe_get_field :naccf_obj nfa))
	  (fld (unsafe_get_field :naccf_fld nfa))
	  (:long fldoff (get_int fld))
	  (boxfldoff (make_integerbox discr_integer fldoff))
	  (cobj (compile_obj obj gcx))
	  ;; we factor the case when the field access cannot be done at
	  ;; compile time
	  (makecompute 
	   (lambda ()
	     (let ( 
		   (tcont 
		    (tuple  
		     (make_stringconst discr_verbatim_string "/*fieldacc*/(melt_field_object((melt_ptr_t)(")
		     cobj
		     (make_stringconst discr_verbatim_string "),")
		     boxfldoff
		     (make_stringconst discr_verbatim_string "))")
		     )) 
		   (res 
		    (instance class_objexpv
			      :obv_type ctype_value
			      :obx_cont tcont))
		   )
	       (debug "compilobj_nrep_fieldacc makecompute res=" res)
	       res
	       )))
	  )
     (assert_msg "compilobj_nrep_fieldacc check fld" (is_a fld class_field) fld)
     (debug "compilobj_nrep_fieldacc cobj=" cobj " fld=" fld)
     (if (is_a cobj class_objinitobject)
	 (let ( (cdata (unsafe_get_field :oie_data cobj)) 
		)
	   (if (is_a cdata class_nrep_datainstance)
	       (let ( (slotup (unsafe_get_field :ninst_slots cdata)) 
		      (ourslot (multiple_nth slotup fldoff)) 
		      )
		 (if (is_a ourslot class_nrep_bound_data)
		     (let ( (cslot (compile_obj ourslot gcx)) )
		       (debug "compilobj_nrep_fieldacc returning cslot=" cslot)
		       (return cslot))
		   (return (makecompute))))
	     (return (makecompute)))
	   )
       (return (makecompute))
       )))
 (install_method class_nrep_fieldacc compile_obj compilobj_nrep_fieldacc)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile an unsafe get field access
 (defun compilobj_nrep_unsafe_get_field (nugf gcx)
   (assert_msg "check nugf" (is_a nugf class_nrep_unsafe_get_field) nugf)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_unsafe_get_field nugf=" nugf)
   (let ( (loc (unsafe_get_field :nrep_loc nugf)) 
	  (nobj (unsafe_get_field :nuget_obj nugf))
	  (nfield (unsafe_get_field :nuget_field nugf))
	  (dlist (make_list discr_list))
	  (oobj (compile_obj nobj gcx))
	  (ogetslot (instance class_objgetslot
			      :obi_loc loc
			      :obdi_destlist dlist
			      :ogetsl_obj oobj
			      :ogetsl_field nfield))
	  )
     (return ogetslot)
     ))
 (install_method class_nrep_unsafe_get_field compile_obj compilobj_nrep_unsafe_get_field)


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile an unsafe put fields
 (defun compilobj_nrep_unsafe_put_fields (nupf gcx)
   (assert_msg "check nupf" (is_a nupf class_nrep_unsafe_put_fields) nupf)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_unsafe_put_fields nupf=" nupf)
   (let ( (loc (unsafe_get_field :nrep_loc nupf)) 
	  (nobj (unsafe_get_field :nuput_obj nupf))
	  (nfldass (unsafe_get_field :nuput_fields nupf))
	  (obodl (make_list discr_list))
	  (oepil (make_list discr_list))
	  (oblock (instance class_objplainblock
			    :obi_loc loc
			    :oblo_bodyl obodl
			    :oblo_epil oepil))
	  (oobj (compile_obj nobj gcx))
	  )
     (foreach_in_multiple 
      (nfldass)
      (nfa :long ix)
      (assert_msg "check nfa" (is_a nfa class_nrep_fieldassign) nfa)
      (let ( (aloc (unsafe_get_field :nrep_loc nfa)) 
	     (afield (unsafe_get_field :nfla_field nfa))
	     (aval (unsafe_get_field :nfla_val nfa))
	     (:long aoff (get_int afield))
	     )
	(assert_msg "check afield" (is_a afield class_field) afield)
	(let ( 
	      (oval (compile_obj aval gcx)) 
	      (opuf (instance class_objputslot
			      :obi_loc (if aloc aloc loc)
			      :oslot_odata oobj
			      :oslot_field afield
			      :oslot_offset (make_integerbox discr_integer aoff)
			      :oslot_value oval)) 
	      )
	  (debug "compilobj_nrep_unsafe_put_fields opuf=" opuf)
	  (assert_msg "compilobj_nrep_unsafe_put_fields check oval not nrep" (is_not_a oval class_nrep) oval)
	  (list_append obodl opuf))
	))

     (list_append obodl (instance class_objtouch
				  :obi_loc loc
				  :otouch_val oobj))
     ;; emit debugtrace of written object
     (list_append obodl (instance class_objdbgtracewriteobj
				  :obi_loc loc
				  :obdtw_writtenobj oobj
				  :obdtw_message '"put-fields"))
     ;; add the updated obj to the block
     (list_append obodl oobj)
     (return oblock)
     ))
 (install_method class_nrep_unsafe_put_fields compile_obj compilobj_nrep_unsafe_put_fields)



 ;;;;
 (defun compilobj_nrep_modulevarocc (nsvar gcx)
   (debug "compilobj_nrep_modulevarocc nsvar=" nsvar)
   (assert_msg "check nsvar" (is_a nsvar class_nrep_modulevarocc) nsvar)
   (let  ( (nvbind (get_field :nmodvar_bind nsvar))
	  )
     (assert_msg "check nvbind" (is_a nvbind class_normal_module_variable_binding) nvbind)
       (let ( (ofetch (instance class_objfetchmodvar
				:obv_type ctype_value
				:obfetchmodvar_bind nvbind))
	      )
	 (debug "compilobj_nrep_modulevarocc ofetch=" ofetch)
	 (return ofetch)
 )))
 (install_method class_nrep_modulevarocc compile_obj compilobj_nrep_modulevarocc)



 ;;;;
 (defun compilobj_nrep_putmodulevar (npvar gcx)
   (debug "compilobj_nrep_putmodulevar npvar=" npvar)
   (assert_msg "check npvar" (is_a npvar class_nrep_putmodulevar) npvar)
   (let ( (loc (unsafe_get_field :nrep_loc npvar)) 
	  (destvar (unsafe_get_field :nputmod_destvar npvar))
	  (nval (unsafe_get_field :nputmod_value npvar))
	  )
     (debug "compilobj_nrep_putmodulevar destvar=" destvar " nval=" nval)
     (assert_msg "check destvar" (is_a destvar class_nrep_modulevarocc) destvar)
     (let ( (modvarbind (get_field :nmodvar_bind destvar))
	    (oval (compile_obj nval gcx))
	    )
       (assert_msg "check modvarbind" (is_a modvarbind class_normal_module_variable_binding) modvarbind)
       (let ( (oput (instance class_objputmodvar
			      :obi_loc loc
			      :obputmodvar_bind modvarbind
			      :obputmodvar_val oval))
	      )
	 (debug "compilobj_nrep_putmodulevar result oput=" oput)
	 (return oput)
	 ))))
 (install_method class_nrep_putmodulevar compile_obj compilobj_nrep_putmodulevar)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun compilobj_nrep_checksignal (nchint gcx)
   (debug "compilobj_nrep_checksignal nchint=" nchint)
   (assert_msg "check nchint" (is_a nchint class_nrep_checksignal) nchint)
   (let (
	 (nloc (unsafe_get_field :nrep_loc nchint))
	 (ochint (instance class_objchecksignal
			   :obi_loc nloc))
	 )
     (debug "compilobj_nrep_checksignal ochint=" ochint)
     (return ochint)
     ))

 (install_method class_nrep_checksignal compile_obj compilobj_nrep_checksignal)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile an unsafe nth component
 (defun compilobj_nrep_unsafe_nth_component (nunc gcx)
   (assert_msg "check nunc" (is_a nunc class_nrep_unsafe_nth_component) nunc)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (debug "compilobj_nrep_unsafe_nth_component nunc=" nunc)
   (let ( (nloc (unsafe_get_field :nrep_loc nunc))
	  (ntup (unsafe_get_field :nunth_tuple nunc))
	  (nidx (unsafe_get_field :nunth_index nunc))
	  (otup (compile_obj ntup gcx))
	  (oidx (compile_obj nidx gcx))
	  (ounc (make_objcompute nloc ctype_value ##{/*unsafenthcomp*/((meltmultiple_ptr_t)($OTUP))->tabval[$OIDX]}#
				 ))
	 )
     (debug "compilobj_nrep_unsafe_nth_component otup=" otup " oidx=" oidx " ounc=" ounc)
     (return ounc)
   ))
 (install_method class_nrep_unsafe_nth_component compile_obj compilobj_nrep_unsafe_nth_component)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a simple application
 (defun compilobj_nrep_apply (napp gcx)
   (debug "compilobj_nrep_apply napp=" napp)
   (assert_msg "check napp" (is_a napp class_nrep_apply) napp)
   (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
   (let ( (loc (unsafe_get_field :nrep_loc napp))
	  (fun (unsafe_get_field :napp_fun napp))
	  (args (unsafe_get_field :nexpr_args napp))
	  )
     (let ( (oclos (compile_obj fun gcx)) 
	    (oargs (multiple_map
		    args
		    (lambda (comp :long ix)
		      (let ( (ocomp (compile_obj comp gcx)) )
			(assert_msg "compilobj_nrep_apply check ocomp not objinstr"
				    (is_not_a ocomp class_objinstr) ocomp)
			ocomp))))
	    (dlist (make_list discr_list))
	    (oapp 
	     (instance 
	      class_objapply
	      :obi_loc loc
	      :obdi_destlist dlist
	      :obapp_clos oclos
	      :obapp_args oargs))
	    )
       (debug "compilobj_nrep_apply return oapp=" oapp)
       oapp
       )))
 (install_method class_nrep_apply compile_obj compilobj_nrep_apply)


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; compile a hook call
(defun compilobj_nrep_hook_call (nhkcall gcx)
  (debug "compilobj_nrep_hook_call nhkcall=" nhkcall)
  (assert_msg "check nhkcall" (is_a nhkcall class_nrep_hook_call) nhkcall)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (loc (unsafe_get_field :nrep_loc nhkcall))
	 (nhkname (unsafe_get_field :nhook_name nhkcall))
	 (nhkctype (unsafe_get_field :nexpr_ctyp nhkcall))
	 (nhook (unsafe_get_field :nhook_called nhkcall))
	 (nargs (unsafe_get_field :nexpr_args nhkcall))
	 (nouts (unsafe_get_field :nhook_outs nhkcall))
	 (nhkdescr (unsafe_get_field :nhook_descr nhkcall))
	 (modctx (unsafe_get_field :gncx_modulcontext gcx))
	 (mhookdict (get_field :mocx_hookdict modctx))
	 )
    (debug "compilobj_nrep_hook_call nhook=" nhook "\n.. nargs=" nargs 
	   "\n.. nouts=" nouts "\n.. nhkname=" nhkname "\n.. nhkdescr=" nhkdescr
	   "\n.. mhookdict=" mhookdict)
    (let ( (ohook (let ( (oh (compile_obj nhook gcx)) )
		    (debug "compilobj_nrep_hook_call ohook=" oh)
		    oh))
	   (oargs (multiple_map
		   nargs
		   (lambda (ncomp :long ix)
		     (debug "compilobj_nrep_hook_call ncomp=" ncomp " ix#" ix)
		     (let ( (ocomp (compile_obj ncomp gcx)) )
		       (debug "compilobj_nrep_hook_call ocomp=" ocomp)
		       (assert_msg "compilobj_nrep_hook_call check ocomp not objinstr"
				   (is_not_a ocomp class_objinstr) ocomp)
		       ocomp))))
	   (oouts (multiple_map
		   nouts 
		   (lambda (nvar :long oix)
		     (debug "compilobj_nrep_hook_call nvar=" nvar " oix#" oix)
		     (let ( (ovar (compile_obj nvar gcx))
			    )
		       (debug "compilobj_nrep_hook_call ovar=" ovar)
		       ovar))))
	   )
      (debug "compilobj_nrep_hook_call ohook=" ohook " oargs=" oargs " oouts=" oouts)
      (let ( 
	    (commastr (make_stringconst discr_verbatim_string ", "))
	    (commampstr (make_stringconst discr_verbatim_string ", &"))
	    (rhkname (clone_with_discriminant nhkname discr_verbatim_string))
	    (addins (lambda (alist)
		      (foreach_in_multiple
		       (oargs)
		       (curarg :long argix)
		       (list_append alist commastr)
		       (list_append alist curarg)
		       )
		      ))
	    (addouts (lambda (alist)
		       (foreach_in_multiple
			(oouts)
			(curout :long outix)
			(list_append alist commampstr)
			(list_append alist curout)
			)
		       ))
	    (ohkcall
	     (make_objlocatedexp 
	      loc nhkctype
	      ##{ /*hookcall*/ melthook_$RHKNAME ((melt_ptr_t) $OHOOK$ADDINS$ADDOUTS) }#
	      ))
	    )
	(when nhkdescr
	  (debug "compilobj_nrep_hook_call nhkdescr=" nhkdescr "\n.. nhkname=" nhkname
		 "\n.. mhookdict=" mhookdict)
	  (assert_msg "check nhkdescr" (is_a nhkdescr class_hook_descriptor) nhkdescr)
	  (let ( (oldescr (mapstring_getstr mhookdict nhkname))
		 )
	    (debug "compilobj_nrep_hook_call nhkdescr=" nhkdescr " oldescr=" oldescr)
	    (if oldescr
		(assert_msg "check oldescr" (== oldescr nhkdescr) oldescr)
	      (progn
		(mapstring_putstr mhookdict nhkname nhkdescr)
		(debug "compilobj_nrep_hook_call updated mhookdict=" mhookdict)
		))))
	(debug "compilobj_nrep_hook_call ohkcall=" ohkcall)
	(return ohkcall)
	))))
(install_method class_nrep_hook_call compile_obj compilobj_nrep_hook_call)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_multiapply (nmapp gcx)
  (assert_msg "check napp" (is_a nmapp class_nrep_multiapply) nmapp)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_multiapply nmapp=" nmapp)
  (let ( (loc (unsafe_get_field :nrep_loc nmapp))
	 (rbinds (unsafe_get_field :nmulapp_bindings nmapp))
	 (fun (unsafe_get_field :napp_fun nmapp))
	 (args (unsafe_get_field :nexpr_args nmapp))
	 (nbody (unsafe_get_field :nmulapp_body nmapp))
	 (locmap (unsafe_get_field :gncx_locmap gcx))
	 (:long nbres (multiple_length rbinds))
	 (reslocs 
	  (multiple_map
	   rbinds
	   (lambda (bind :long ix)
	     (assert_msg "compilobj_nrep_multiapply check bind" 
			 (is_a bind class_formal_binding) bind)
	     (let ( (bder (unsafe_get_field :binder bind))
		    (cty (unsafe_get_field :fbind_type bind)) 
		    (obva (get_free_objloctyped gcx bder cty))
		    )
	       (assert_msg "compilobj_nrep_multiapply check cty" 
			   (is_a cty class_ctype) cty)
	       ;; link nlbnd to obva in locmap
	       (if obva (mapobject_put locmap bind obva))
	       obva
	       ))))
	 (obodl (make_list discr_list))
	 (oepil (make_list discr_list))
	 (oblock (instance class_objplainblock
			   :obi_loc loc
			   :oblo_bodyl obodl
			   :oblo_epil oepil))
	 (oxres (if (>i nbres 1) (make_multiple discr_multiple (-i nbres 1)) ()))
	 (firstres (multiple_nth reslocs 0))
	 (ofun (compile_obj fun gcx))
	 (reslist (make_list discr_list))
	 (oargs (multiple_map args
			      (lambda (comp :long ix)
				(compile_obj comp gcx))))
	 (obody (compile_obj nbody gcx))
	 (omapp (instance class_objmultiapply
			  :obi_loc loc
			  :obdi_destlist reslist
			  :obapp_clos (compile_obj fun gcx)
			  :obapp_args oargs
			  :obmultapp_xres oxres))
	 )
    (if firstres (list_append reslist firstres))
    ;; add every compiled argument to the resulting block unless it is a pure value
    (foreach_in_multiple 
     (oargs)
     (ocurarg :long ix)
       (if 
	   (and ocurarg 
		(or (is_not_a ocurarg class_objpurevalue) 
		    (is_a ocurarg class_objinstr)))
	   (list_append obodl ocurarg)))
    ;; add the multiapply to the block
    (list_append obodl omapp)
    ;; add the compiled body to the block
    (list_append obodl obody)
    ;; add the clearing of each result to epilog
    (foreach_in_multiple 
     (reslocs)
     (rloc :long ix)
     (if (>i ix 0) 
	 (let ( (oclear (instance class_objclear 
				  :obi_loc loc
				  :oclr_vloc rloc)) )
	   (list_append oepil oclear)
	   (multiple_put_nth oxres (-i ix 1) rloc)
	   )))
    ;; dispose the local bindings
    (foreach_in_multiple
     (rbinds)
     (bind :long ix) (dispose_bnd_obj bind gcx))
    (debug "compilobj_nrep_multiapply final oblock=" oblock)
    oblock
    ))
(install_method class_nrep_multiapply compile_obj compilobj_nrep_multiapply)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; compile a simple message send
(defun compilobj_nrep_msend (nsnd gcx)
  (assert_msg "check nsnd" (is_a nsnd class_nrep_msend) nsnd)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (loc (unsafe_get_field :nrep_loc nsnd))
	 (nsel (unsafe_get_field :nsend_sel nsnd))
	 (nrecv (unsafe_get_field :nsend_recv nsnd))
	 (nargs (unsafe_get_field :nexpr_args nsnd))
	 )
    (debug "compilobj_nrep_msend nsnd=" nsnd)
    (assert_msg "check nrecv" (is_object nrecv) nrecv)
    (let ( (osel (compile_obj nsel gcx))
	   (orecv (compile_obj nrecv gcx))
	   (oargs (multiple_map 
		   nargs
		   (lambda (ncurarg :long ix)
		     (debug "compilobj_nrep_msend ncurarg=" ncurarg " ix=" ix)
		     (let ( (ocurarg (compile_obj ncurarg gcx)) 
			    )
		       (debug "compilobj_nrep_msend ocurarg=" ocurarg)
		       (assert_msg "check ocurarg not tuple" (not (is_multiple ocurarg)) ocurarg)
		       ocurarg
		       ))))
	   (osend
	    (instance 
	     class_objmsend
	     :obi_loc loc
	     :obdi_destlist (make_list discr_list)
	     :obmsnd_sel osel
	     :obmsnd_recv orecv
	     :obmsnd_args oargs
	     ))
	   )
      (debug "compilobj_nrep_msend osend=" osend)
      (assert_msg "check orecv" (is_object orecv) orecv)
      osend
      )))
(install_method class_nrep_msend compile_obj compilobj_nrep_msend)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; compile a multiresult message send
(defun compilobj_nrep_multimsend (nmsnd gcx)
  (assert_msg "check nmsnd" (is_a nmsnd class_nrep_multimsend) nmsnd)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_multimsend nmsnd=" nmsnd)
  (let ( (loc (unsafe_get_field :nrep_loc nmsnd)) 
	 (rbinds (unsafe_get_field :nmulsend_bindings nmsnd))
	 (nbody (unsafe_get_field :nmulsend_body nmsnd)) ; a single normalized expression
	 (nsel (unsafe_get_field :nsend_sel nmsnd))
	 (nrecv (unsafe_get_field :nsend_recv nmsnd))
	 (nargs (unsafe_get_field :nexpr_args nmsnd))
	 (locmap (unsafe_get_field :gncx_locmap gcx))
	 (:long nbres (multiple_length rbinds))
	 (reslocs 
	  (multiple_map
	   rbinds
	   (lambda (bind :long ix)
	     (assert_msg "compilobj_nrep_multimsend check bind" 
			 (is_a bind class_formal_binding) bind)
	     (let ( (bder (unsafe_get_field :binder bind))
		    (cty (unsafe_get_field :fbind_type bind)) 
		    (obva (get_free_objloctyped gcx bder cty))
		    )
	       (assert_msg "compilobj_nrep_multimsend check cty" 
			   (is_a cty class_ctype) cty)
	       ;; link nlbnd to obva in locmap
	       (if obva (mapobject_put locmap bind obva))
	       obva
	       ))))
	 (oxres (if (>i nbres 1) 
		    (make_multiple discr_multiple  (-i nbres 1))))
	 (firstres (multiple_nth reslocs 0))
	 (osel (compile_obj nsel gcx))
	 (reslist (make_list discr_list))
	 (orecv (compile_obj nrecv gcx))
	 (oargs (multiple_map nargs
			      (lambda (comp :long ix)
				(compile_obj comp gcx))))
	 (obody (compile_obj nbody gcx))
	 (obodl (make_list discr_list))
	 (oepil (make_list discr_list))
	 (oblock (instance class_objplainblock
			   :obi_loc loc
			   :oblo_bodyl obodl
			   :oblo_epil oepil))
	 (omsend (instance class_objmultimsend
			   :obi_loc loc
			   :obdi_destlist reslist
			   :obmsnd_sel osel
			   :obmsnd_recv orecv
			   :obmsnd_args oargs
			   :obmultsnd_xres oxres))
	 )
    (assert_msg "check orecv" (is_object orecv) orecv)
    (if firstres (list_append reslist firstres))
    ;; add every compiled argument to the resulting block unless it is a pure value
    (foreach_in_multiple 
     (oargs)
     (ocurarg :long ix)
     (if (and ocurarg (or (is_not_a ocurarg class_objpurevalue) (is_a ocurarg class_objinstr)))
	 (list_append obodl ocurarg)))
    ;; add the multisend to the block
    (list_append obodl omsend)
    ;; add the compiled body to the block
    (list_append obodl obody)
    ;; add the clearing of each result to epilog
    (multiple_every 
     reslocs
     (lambda (rloc :long ix)
       (if (>i ix 0)
	   (let ( (oclear (instance class_objclear 
				    :obi_loc loc
				    :oclr_vloc rloc)) )
	     (list_append oepil oclear)
	     (multiple_put_nth oxres (-i ix 1) rloc)))))
    ;; dispose the local bindings
    (multiple_every 
     rbinds
     (lambda (bind :long ix) (dispose_bnd_obj bind gcx)))
    (debug  "compilobj_nrep_multimsend final oblock=" oblock)
    oblock
    ))

(install_method class_nrep_multimsend compile_obj compilobj_nrep_multimsend)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compile bindings
(defun compilobj_any_binding  (bind gcx)
  (assert_msg "check bind" (is_a bind class_any_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_any_binding bind=" bind)
  (outcstring_err "* compilobj unimplemented receiver binding class ")
  (let ( (discr (discrim bind)) ) (outstr_err (unsafe_get_field :named_name discr)))
  (outnewline_err)
  (assert_msg "@@compile_obj should be implemented in anybinding-s subclasses" () bind))
  
(install_method class_any_binding compile_obj compilobj_any_binding)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compile value bindings
(defun compilobj_value_binding  (bind gcx)
  (assert_msg "check bind" (is_a bind class_value_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx)
  (debug "compilobj_value_binding bind=" bind)
  (let ( (sym (get_field :binder bind))
	 (importmap (get_field :igncx_importmap gcx))
	 (olocv (mapobject_get importmap sym))
	 )
    (debug "compilobj_value_binding olocv=" olocv " importmap=" importmap)
    (assert_msg "check olocv" (is_a olocv class_objlocv) olocv)
    (return olocv)
    )
  )
(install_method class_value_binding compile_obj compilobj_value_binding)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_fixed_binding (bind gcx)
  (assert_msg "check bind" (is_a bind class_fixed_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_fixed_binding bind=" bind)
  (let ( (sbdata (unsafe_get_field :fixbind_data bind)) 
	 (osdata (compile_obj sbdata gcx)) )
    (debug "compilobj_fixed_binding sbdata=" sbdata " osdata=" osdata)
    (return osdata)
    )
  )
(install_method class_fixed_binding compile_obj compilobj_fixed_binding)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_normal_let_binding (bind gcx)
  (assert_msg "check bind" (is_a bind class_normal_let_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_normal_let_binding bind=" bind)
  (let ( (nexpr (unsafe_get_field :letbind_expr bind)) 
	 (ctyp (unsafe_get_field :letbind_type bind))
	 (bnder (unsafe_get_field :binder bind))
	 (oexpr (compile_obj nexpr gcx)) )
    (debug "compilobj_normal_let_binding oexpr=" oexpr)
    (assert_msg "compilobj_normal_let_binding got here" () bind oexpr)
    (return oexpr)
    )
  )
(install_method class_normal_let_binding compile_obj compilobj_normal_let_binding)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_conslambdabind (bind gcx)
  (assert_msg "check bind" (is_a bind class_normal_constructed_lambda_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_conslambdabind bind=" bind)
  (let ( (symb (unsafe_get_field :binder bind))
	 (loc (unsafe_get_field :nconsb_loc bind))
	 (ndiscr (unsafe_get_field :nconsb_discr bind))
	 (nclosed (unsafe_get_field :nlambdab_nclosed bind))
	 (ndatarout (unsafe_get_field :nlambdab_datarout bind))
	 (nconstrout (unsafe_get_field :nlambdab_constrout bind))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (odiscr (compile_obj ndiscr gcx))
	 (nambuf (make_strbuf discr_strbuf))
	 (nlocsyms (get_field :nletrec_locsyms nletrec))
	 (:long bindnum (get_int bind))
	 (:long nbclosed (multiple_length nclosed))
	 (locsymocc (multiple_nth nlocsyms bindnum))
	 )
    (let ( 
	  (orout (compile_obj nconstrout gcx))
	  (oloc (compile_obj locsymocc gcx))
	  )
      (add2sbuf_strconst nambuf "rclo_")
      (add2sbuf_longdec nambuf bindnum)
      (add2sbuf_strconst nambuf "__")
      (add2sbuf_cident nambuf (unsafe_get_field :named_name symb))
      (if (is_a symb class_cloned_symbol)
	  (progn
	    (add2sbuf_strconst nambuf "_x")
	    (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb)))))
      (let ( (iniclos (instance class_objinitclosure
				:obv_type ctype_value
				:oie_discr odiscr
				:oie_locvar oloc
				:oie_cname (strbuf2string discr_string nambuf)
				:oiclo_rout orout
				))
	     )
	(put_int iniclos nbclosed)
	(debug "compilobj_conslambdabind returning iniclos=" iniclos)
	iniclos
	))))
(install_method class_normal_constructed_lambda_binding compile_obj compilobj_conslambdabind)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_constuplebind (bind gcx)
  (debug "compilobj_constuplebind bind=" bind)
  (assert_msg "check bind" (is_a bind class_normal_constructed_tuple_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (symb (unsafe_get_field :binder bind))
	 (nloc (unsafe_get_field :nconsb_loc bind))
	 (ndiscr (unsafe_get_field :nconsb_discr bind))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (ntupb (unsafe_get_field :ntupb_comp bind))
	 (odiscr (compile_obj ndiscr gcx))
	 (nambuf (make_strbuf discr_strbuf))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (nlocsyms (get_field :nletrec_locsyms nletrec))
	 (:long bindnum (get_int bind))
	 (:long lentup (multiple_length ntupb))
	 (locsymocc (multiple_nth nlocsyms bindnum))
	 )
      (add2sbuf_strconst nambuf "rtup_")
      (add2sbuf_longdec nambuf bindnum)
      (add2sbuf_strconst nambuf "__")
      (add2sbuf_cident nambuf (unsafe_get_field :named_name symb))
      (if (is_a symb class_cloned_symbol)
	  (progn
	    (add2sbuf_strconst nambuf "_x")
	    (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb)))))
      (let ( 
	    (oloc (compile_obj locsymocc gcx))
	    (tupval (make_multiple discr_multiple lentup))
	    (initup (instance class_objinitmultiple
			       :obv_type ctype_value
			       :oie_discr odiscr
			       :oie_locvar oloc
			       :oie_cname (strbuf2string discr_string nambuf)
			       :oim_tupval tupval
			       ))
	    )
	(put_int initup lentup)
	(debug "compilobj_constuplebind result initup=" initup)
	initup
	)
    ))
(install_method class_normal_constructed_tuple_binding compile_obj compilobj_constuplebind)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_conspairbind (bind gcx)
  (debug "compilobj_conspairbind bind=" bind)
  (assert_msg "check bind" (is_a bind class_normal_constructed_pair_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (symb (unsafe_get_field :binder bind))
	 (nloc (unsafe_get_field :nconsb_loc bind))
	 (ndiscr (unsafe_get_field :nconsb_discr bind))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (nhead (unsafe_get_field :npairb_head bind))
	 (ntail (unsafe_get_field :npairb_tail bind))
	 (nlocsyms (get_field :nletrec_locsyms nletrec))
	 (odiscr (compile_obj ndiscr gcx))
	 (nambuf (make_strbuf discr_strbuf))
	 (:long bindnum (get_int bind))
	 (locsymocc (multiple_nth nlocsyms bindnum))
	 )
    (assert_msg "check nletrec" nletrec)
    (add2sbuf_strconst nambuf "rpair_")
    (add2sbuf_longdec nambuf bindnum)
    (add2sbuf_strconst nambuf "__")
    (add2sbuf_cident nambuf (unsafe_get_field :named_name symb))
    (if (is_a symb class_cloned_symbol)
	(progn
	  (add2sbuf_strconst nambuf "_x")
	  (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb)))))
    (let ( 
	  (oloc (compile_obj locsymocc gcx))
	  (inipair (instance class_objinitpair
			     :obv_type ctype_value
			     :oie_discr odiscr
			     :oie_locvar oloc
			     :oie_cname (strbuf2string discr_string nambuf)))
	  )
      (debug "compilobj_conspairbind return inipair=" inipair)
      (return inipair)
      )))
(install_method class_normal_constructed_pair_binding compile_obj compilobj_conspairbind)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_conslistbind (bind gcx)
  (debug "compilobj_conslistbind bind=" bind)
  (assert_msg "check bind" (is_a bind class_normal_constructed_list_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (symb (unsafe_get_field :binder bind))
	 (nloc (unsafe_get_field :nconsb_loc bind))
	 (ndiscr (unsafe_get_field :nconsb_discr bind))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (nfirst (unsafe_get_field :nlistb_first bind))
	 (nlast (unsafe_get_field :nlistb_last bind))
	 (nlocsyms (get_field :nletrec_locsyms nletrec))
	 (odiscr (compile_obj ndiscr gcx))
	 (nambuf (make_strbuf discr_strbuf))
	 (:long bindnum (get_int bind))
	 (locsymocc (multiple_nth nlocsyms bindnum))
	 )
    (add2sbuf_strconst nambuf "rlist_")
    (add2sbuf_longdec nambuf bindnum)
    (add2sbuf_strconst nambuf "__")
    (add2sbuf_cident nambuf (unsafe_get_field :named_name symb))
    (let ( 
	  (oloc (compile_obj locsymocc gcx))
	  (inilist (instance class_objinitlist
			     :obv_type ctype_value
			     :oie_discr odiscr
			     :oie_locvar oloc
			     :oie_cname (strbuf2string discr_string nambuf)
			     ))
	  )
      (debug "compilobj_conslistbind return inilist=" inilist)
      (return inilist)
      )))
(install_method class_normal_constructed_list_binding compile_obj compilobj_conslistbind)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_consinstancebind (bind gcx)
  (debug  "compilobj_consinstancebind bind=" bind)
  (assert_msg "check bind" (is_a bind class_normal_constructed_instance_binding) bind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (symb (unsafe_get_field :binder bind))
	 (nloc (unsafe_get_field :nconsb_loc bind))
	 (ndiscr (unsafe_get_field :nconsb_discr bind))
	 (nletrec (unsafe_get_field :nconsb_nletrec bind))
	 (nslots (unsafe_get_field :ninstb_slots bind))
	 (nambuf (make_strbuf discr_strbuf))
	 (odiscr (compile_obj ndiscr gcx))
	 (nlocsyms (get_field :nletrec_locsyms nletrec))
	 (:long bindnum (get_int bind))
	 (locsymocc (multiple_nth nlocsyms bindnum))
	 (nclabind (get_field :ninstb_clabind bind))
	 )
    (add2sbuf_strconst nambuf "rinst_")
    (add2sbuf_longdec nambuf bindnum)
    (add2sbuf_strconst nambuf "__")
    (add2sbuf_cident nambuf (unsafe_get_field :named_name symb))
    (let ( 
	  (oloc (compile_obj locsymocc gcx))
	  (clas (cond ( (is_a nclabind class_value_binding)
		       (unsafe_get_field :vbind_value nclabind))
		     ( (is_a nclabind class_class_binding)
		       (unsafe_get_field :cbind_class nclabind))
		     (:else
		      (debug "compilobj_consinstancebind bad nclabind=" nclabind)
		      (assert_msg "unexpected class binding" () nclabind))))
	  (ininst (instance class_objinitobject
			    :obv_type ctype_value
			    :oie_discr odiscr
			    :oie_locvar oloc
			    :oie_cname (strbuf2string discr_string nambuf)
			    :oio_class clas
			    ))
	  )
      ;; set the length of the instance
      (put_int ininst (multiple_length (get_field :class_fields clas)))
      (debug "compilobj_consinstancebind return ininst=" ininst)
      (return ininst)
      )))
(install_method class_normal_constructed_instance_binding compile_obj compilobj_consinstancebind)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun putobjdest_objvalue (recv desto)
  (assert_msg "check recv" (is_a recv class_objvalue) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (typrecv (unsafe_get_field :obv_type recv))
	 (typdesto (get_field :obv_type desto)) 
	 )
    (cond
     ;; special case when receiver is void
     ( (== typrecv ctype_void)
       (if (== typdesto ctype_void)
	   (return recv)
	 ;; if recv is void we just create a block with recv and the
	 ;; clear of desto
	 (let ( 
	       (obodl (make_list discr_list))
	       (oblk (instance class_objplainblock
			       ;; dont fill :obi_loc
			       :oblo_bodyl obodl
			       :oblo_epil ()
			       )
		     )
	       (oclr (instance class_objclear
			       ;; dont fill :obi_loc
			       :oclr_vloc desto
			       ))
	       )
	   (list_append obodl recv)
	   (list_append obodl oclr)
	   ;; the last of the block is the destination location, to
	   ;; avoid latter putobjdest-s on the objclear
	   (list_append obodl desto)
	   (return oblk)
	   )))
     ;; common case when desto & recv have same type
     ( (== typrecv typdesto)
       (assert_msg "check same typrecv&rtpdesto" (is_a typrecv class_ctype) typrecv)
       (let ( (destlis (make_list discr_list))
	      (explis (make_list discr_list))
	      (obc (instance class_objcompute
			     ;; dont fill :obi_loc
			     :obdi_destlist destlis
			     :obcpt_expr explis
			     :obcpt_type typrecv
			     )) 
	      )
	 (list_append destlis desto)
	 (list_append explis recv)
	 (return obc)))
     ;; error case: type mismatch
     (:else
      (debug "putobjdest_objvalue mismatching recv=" recv " typrecv=" typrecv " desto=" desto " typdesto=" typdesto)
      (outcstring_err "putobjdest_objvalue type mismatch : recv <")
      (let ( (discr (discrim recv)) ) (outstr_err (unsafe_get_field :named_name discr)))
      (outcstring_err "> & desto<") 
      (let ( (discr (discrim desto)) ) (outstr_err (unsafe_get_field :named_name discr)))
      (outcstring_err ">")
      (outnewline_err)
      (assert_msg "putobjdest_objvalue type mismatch" () recv desto)
      (return recv)))
    ))

(install_method class_objvalue  put_objdest  putobjdest_objvalue)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun putobjdest_integer (recv desto)
  (debug "putobjdest_integer recv=" recv "\n* desto=" desto
	 "\n* of discrim:" (discrim desto) "\n* class_objlocv=" class_objlocv)
  (assert_msg "check recv" (is_integerbox recv) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (destlis (make_list discr_list))
	 (explis (make_list discr_list))
	 (typdesto (get_field :obv_type desto))
	 (obc (instance class_objcompute
			;; dont fill :obi_loc
			:obdi_destlist destlis
			:obcpt_expr explis
			:obcpt_type ctype_long
			)) 
	 )
    (assert_msg "check typdesto" (== typdesto ctype_long) typdesto)
    (list_append destlis desto)
    (list_append explis recv)
    (debug "putobjdest_integer return obc=" obc)
    obc
    ))
(install_method discr_integer put_objdest putobjdest_integer)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; put obj destination inside a string
;;; useful to compile (let ( (:cstring foo "abc") ) ...)
(defun putobjdest_string (recv desto)
  (assert_msg "check recv" (is_string recv) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (debug "putobjdest_string recv=" recv " desto=" desto)
  (let ( (destlis (make_list discr_list))
	 (explis (make_list discr_list))
	 (typdesto (unsafe_get_field :obv_type desto))
	 (obc (instance class_objcompute
			;; dont fill :obi_loc
			:obdi_destlist destlis
			:obcpt_expr explis
			:obcpt_type ctype_cstring
			)) 
	 )
    (assert_msg "check typdesto" (== typdesto ctype_cstring) typdesto)
    (list_append destlis desto)
    (list_append explis recv)
    (debug "putobjdest_string return obc=" obc)
    obc
    ))
(install_method discr_string put_objdest putobjdest_string)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun putobjdest_null (recv desto)
  (assert_msg "check recv" (null recv))
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (debug "putobjdest_null recv=" recv " desto=" desto)
  (if (melt_need_dbg 0) (shortbacktrace_dbg "putobjdest_null" 15))
  (let ( (destlis (make_list discr_list))
	 (explis (make_list discr_list))
	 (typdesto (unsafe_get_field :obv_type desto))
	 (obc (instance class_objcompute
			;; dont fill :obi_loc
			:obdi_destlist destlis
			:obcpt_expr explis
			:obcpt_type typdesto
			)) 
	 )
    (list_append destlis desto)
    (if (== typdesto ctype_long)
	(list_append explis (make_integerbox discr_integer 0))
      (list_append explis recv))
    (debug "putobjdest_null return obc=" obc)
    obc
    ))
(install_method discr_null_receiver put_objdest putobjdest_null)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun putobjdest_objanyblock (recv desto)
  (assert_msg "check recv" (is_a recv class_objanyblock) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (obl (unsafe_get_field :oblo_bodyl recv))
	 (oep (unsafe_get_field :oblo_epil recv))
	 )
    (assert_msg "check obl" (is_list_or_null obl) obl)
    (assert_msg "check oep" (is_list_or_null oep) oep)
    ;; maybe we should remove in the epilogue any clear of same ctype & offset
    (let ( (lpby (list_last obl))
	   (lasbp (pair_head lpby))
	   )
      (if lasbp 
	  (let ( (uplasb (put_objdest lasbp desto)) )
	    (pair_set_head lpby uplasb)
	    )
	)
      )
    recv
    ))

(install_method class_objanyblock  put_objdest  putobjdest_objanyblock)


;;;;;;;;;;
(defun putobjdest_objmultiblock (recv desto)
  (assert_msg "check recv" (is_a recv class_objmultiblock) recv)
  (debug "putobjdest_objmultiblock recv=" recv " desto=" desto)
  (let ( (osubcomp (unsafe_get_field :omulblo_subcomp recv)) )
    (assert_msg "check osubcomp" (is_multiple_or_null osubcomp) osubcomp)
    (foreach_in_multiple
     (osubcomp)
     (cursubcomp :long curix)
     (put_objdest cursubcomp desto))
    (debug  "putobjdest_objmultiblock done recv=" recv)
))
(install_method class_objmultiblock put_objdest putobjdest_objmultiblock)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun putobjdest_objloop (recv desto)
  (assert_msg "check recv" (is_a recv class_objloop) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (epil (unsafe_get_field :oblo_epil recv)) 
	 (resv (unsafe_get_field :obloop_resv recv))
	 (destlist (make_list discr_list))
	 (obc (instance class_objcompute
			;; dont fill :obi_loc
			:obdi_destlist destlist
			:obcpt_expr resv
			:obcpt_type ctype_value
			))
	 )
    (list_append destlist desto)
    (assert_msg "check epil" (is_list epil) epil)
    (assert_msg "check resv" (is_a resv class_objlocv) resv)
    (list_append epil obc)
    )
  (debug "putobjdest loop updated recv=" recv)
  recv
  )
(install_method class_objloop  put_objdest  putobjdest_objloop)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; do nothing when puting a destination into an objexit
(defun putobjdest_objexit (recv desto)
  (assert_msg "check recv" (is_a recv class_objexit) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  recv
  )
(install_method class_objexit put_objdest putobjdest_objexit)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_if (rif gcx)
  (assert_msg "check rif" (is_a rif class_nrep_if) rif)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_if rif=" rif)
  (let ( (loc (unsafe_get_field :nrep_loc rif))
	 (ntest (unsafe_get_field :nif_test rif))
	 (nthen (unsafe_get_field :nif_then rif))
	 (nelse (unsafe_get_field :nif_else rif))
	 (nctyp (unsafe_get_field :nexpr_ctyp rif))
	 )
    (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp)
    (let ( (otest (compile_obj ntest gcx))
	   (othen (compile_obj nthen gcx))
	   (oelse (if (is_not_a nelse class_nrep_nil) 
		      (compile_obj nelse gcx)))
	   (obif (instance class_objcond
			   :obi_loc loc
			   :obcond_test otest
			   :obcond_then othen
			   :obcond_else oelse))
	   )
      (debug "compilobj_nrep_if ntest=" ntest " otest=" otest)
      (debug "compilobj_nrep_if nthen=" nthen " otest=" othen)
      (debug "compilobj_nrep_if nthen=" nelse " otest=" oelse)
      (debug "compilobj_nrep_if obif=" obif)
      (assert_msg "check otest" (notnull otest) otest)
      obif
      )))
(install_method class_nrep_if compile_obj compilobj_nrep_if)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_ifisa (rif gcx)
  (debug "compilobj_nrep_ifisa rif=" rif)
  (assert_msg "check rif" (is_a rif class_nrep_ifisa) rif)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (loc (unsafe_get_field :nrep_loc rif))
	 (nthen (unsafe_get_field :nif_then rif))
	 (nelse (unsafe_get_field :nif_else rif))
	 (nctyp (unsafe_get_field :nexpr_ctyp rif))
	 (nval (get_field :nif_testval rif))
	 (ncla (unsafe_get_field :nifa_class rif))
	 )
    (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp)
    (let ( (othen (compile_obj nthen gcx))
	   (oval (compile_obj nval gcx))
	   (ocla (compile_obj ncla gcx))
	   (oelse (if (is_not_a nelse class_nrep_nil) 
		      (compile_obj nelse gcx)))
	   (otest (make_objlocatedexp loc ctype_long
				      ##{/*ifisa*/ melt_is_instance_of((melt_ptr_t)($OVAL), 
                                                                       (melt_ptr_t)($OCLA))
				      }#))
	   (obif (instance class_objcond
			   :obi_loc loc
			   :obcond_test otest
			   :obcond_then othen
			   :obcond_else oelse))
	   )
      (debug "compilobj_nrep_ifisa obif=" obif)
      obif
      )))
(install_method class_nrep_ifisa compile_obj compilobj_nrep_ifisa)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_ifsame (rif gcx)
  (debug "compilobj_nrep_ifsame rif=" rif "\n gcx=" gcx)
  (assert_msg "check rif" (is_a rif class_nrep_ifsame) rif)
  (let ( (nloc (get_field :nrep_loc rif))
	 (nleft (get_field :nifs_left rif))
	 (nright (get_field :nifs_right rif))
	 (nthen (get_field :nif_then rif))
	 (nelse (get_field :nif_else rif))
	 )
    (let ( (othen (compile_obj nthen gcx))
	   (oleft (compile_obj nleft gcx))
	   (oright (compile_obj nright gcx))
	   (oelse (if (is_not_a nelse class_nrep_nil) 
		      (compile_obj nelse gcx)))
	   (otest (make_objlocatedexp nloc ctype_long
				      ##{/*ifsame*/ ($OLEFT) == ($ORIGHT)}#))
	   (obif (instance class_objcond
			   :obi_loc nloc
			   :obcond_test otest
			   :obcond_then othen
			   :obcond_else oelse))
	   )
      (debug "compilobj_nrep_ifsame result obif=" obif)
      (return obif)
      )))
(install_method class_nrep_ifsame compile_obj compilobj_nrep_ifsame)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_iftuplesized (rif gcx)
  (debug "compilobj_nrep_ifisa rif=" rif)
  (assert_msg "check rif" (is_a rif class_nrep_iftuplesized) rif)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (loc (unsafe_get_field :nrep_loc rif))
	 (nthen (unsafe_get_field :nif_then rif))
	 (nelse (unsafe_get_field :nif_else rif))
	 (nval (get_field :nif_testval rif))
	 (ntsz (get_field :nif_tupsiz rif))
	 )
    (debug "compilobj_nrep_iftuplesized nval=" nval " ntsz=" ntsz)
    (let (  (othen (compile_obj nthen gcx))
	    (oval (compile_obj nval gcx))
	    (oelse (compile_obj nelse gcx))
	    (oval (compile_obj nval gcx))
	    (otsz (compile_obj ntsz gcx))
	    (otest
	     (make_objlocatedexp loc ctype_long
				 ##{/*iftuplesized*/ melt_magic_discr((melt_ptr_t)($OVAL)) == MELTOBMAG_MULTIPLE
				 && ((meltmultiple_ptr_t)($OVAL))->nbval == (int)($OTSZ)}#))
	   (obif (instance class_objcond
			   :obi_loc loc
			   :obcond_test otest
			   :obcond_then othen
			   :obcond_else oelse))
	  )
      (debug "compilobj_nrep_iftuplesized obif=" obif)
      obif
)))
(install_method class_nrep_iftuplesized compile_obj compilobj_nrep_iftuplesized)

;;;;;;;;;;;;;;;;
(defun compilobj_nrep_ifvariadic (rif gcx)
  (assert_msg "check rif" (is_a rif class_nrep_ifvariadic) rif)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug  "compilobj_nrep_ifvariadic rif=" rif)
  (let ( (loc (unsafe_get_field :nrep_loc rif))
	 (nthen (unsafe_get_field :nif_then rif))
	 (nelse (unsafe_get_field :nif_else rif))
	 (nvariadic (unsafe_get_field :nifv_variadic rif))
	 (nvctypes (unsafe_get_field :nifv_ctypes rif))
	 (:long nbvararg (multiple_length nvctypes))
	 )
    (assert_msg "check nvctypes" (is_multiple_or_null nvctypes) nvctypes)
    (assert_msg "check nvariadic" (is_a nvariadic class_symbol) nvariadic)
    (debug "compilobj_nrep_ifvariadic nthen=" nthen "\n.. nelse=" nelse
	   "\n.. nvariadic=" nvariadic " loc=" loc)
    (let ( 
	  (ovariadicindex (variadic_index_idstr nvariadic))
	  (ovariadiclength (variadic_length_idstr nvariadic))
	  (otestchklist 
	   (if (<=i nbvararg 0) 
	       (list
		(make_stringconst discr_verbatim_string "/*ifvariadic nomore*/ ")
		ovariadicindex
		(make_stringconst discr_verbatim_string " == ")
		ovariadiclength
		)
	     (let ( (ovlist
		     (list
		      (make_stringconst discr_verbatim_string "/*ifvariadic arg#")
		      (make_integerbox discr_constant_integer nbvararg)
		      (make_stringconst discr_verbatim_string "*/ ")
		       ovariadicindex
		      (make_stringconst discr_verbatim_string ">=0 && ")
		      ovariadicindex
		      (make_stringconst discr_verbatim_string " + ")
		      (make_integerbox discr_constant_integer nbvararg)
		      (make_stringconst discr_verbatim_string " <= ")
		      ovariadiclength
		      ))
		    )
	       (foreach_in_multiple
		(nvctypes)
		(curctyp :long ix)
		(debug "compilobj_nrep_ifvariadic curctyp" curctyp " ix=" ix
		       "; loc=" loc)
		(assert_msg "check curctyp" (is_a curctyp class_ctype) curctyp)
		(list_append ovlist (make_stringconst discr_verbatim_string " && meltxargdescr_["))
		(list_append ovlist ovariadicindex)
		(if ix
		    (progn
		      (list_append ovlist (make_stringconst discr_verbatim_string " + "))
		      (list_append ovlist (make_integerbox discr_constant_integer ix))))
		(list_append ovlist (make_stringconst discr_verbatim_string "]== "))
		(list_append ovlist 
			     (make_string discr_verbatim_string 
					  (get_field :ctype_parchar curctyp)))
		)
	       (debug "compilobj_nrep_ifvariadic ovlist=" ovlist"; loc=" loc)
	       ovlist))
	   )
	  (otest (instance  class_objexpv
			    :obx_cont (list_to_multiple otestchklist discr_multiple)))
	  (othen 
	   (progn 
	     (debug "compilobj_nrep_ifvariadic before compiling nthen=" nthen"; loc=" loc)
	     (let ( (objthen (compile_obj nthen gcx))
		    )
	       (debug "compilobj_nrep_ifvariadic after compiling nthen=" nthen 
		      " objthen=" objthen"; loc=" loc)
	       objthen)))
	  (oelse 
	   (progn 
	     (debug "compilobj_nrep_ifvariadic before compiling nelse=" nelse "; loc=" loc)
	     (let ( (objelse (compile_obj nelse gcx))
		    )
	       (debug "compilobj_nrep_ifvariadic after compiling nelse=" nelse
		      " objelse=" objelse"; loc=" loc)
	       objelse)))
	  (ocond (instance class_objcond
			   :obi_loc loc
			   :obcond_test otest
			   :obcond_then othen
			   :obcond_else oelse))
	  )
      (debug "compilobj_nrep_ifvariadic ocond=" ocond"; loc=" loc)
      (return ocond))))
(install_method class_nrep_ifvariadic compile_obj compilobj_nrep_ifvariadic)

(defun getctype_ifvariadic (rif env)
  (assert_msg "check ifvariadic" (is_a rif class_nrep_ifvariadic) rif)
  ctype_void)
(install_method class_nrep_ifvariadic get_ctype getctype_ifvariadic)


;;;;;;;;;;;;;;;;

(defun compilobj_nrep_variadic_argument (nvarg gcx)
  (debug "compilobj_nrep_variadic_argument nvarg=" nvarg)
  (assert_msg "check nvarg" (is_a nvarg class_nrep_variadic_argument) nvarg)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (nloc (unsafe_get_field :nrep_loc nvarg))
	 (nvariadic (unsafe_get_field :nvarg_variadic nvarg))
	 (nctyp (unsafe_get_field :nvarg_ctyp nvarg))
	 (noffset (unsafe_get_field :nvarg_offset nvarg))
	 (ovariadicindex (variadic_index_idstr nvariadic))
	 (ovariadiclength (variadic_length_idstr nvariadic))
	 )
    (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp)
    (assert_msg "check noffset" (is_integerbox noffset) noffset)
    (let (
	  (otuple 
	   (if (== nctyp ctype_value)
	       (tuple
		(make_stringconst discr_verbatim_string "/*variadic argument value*/ ((meltxargtab_[")
		ovariadicindex
		(make_stringconst discr_verbatim_string " + ")
		noffset
		(make_stringconst discr_verbatim_string "].meltbp_aptr) ? (*(meltxargtab_[")
		ovariadicindex
		(make_stringconst discr_verbatim_string " + ")
		noffset
		(make_stringconst discr_verbatim_string "].meltbp_aptr)) : NULL)")
		)
	     (tuple
	      (make_stringconst discr_verbatim_string "/*variadic argument stuff*/ meltxargtab_[")
	      ovariadicindex
	      (make_stringconst discr_verbatim_string " + ")
	      noffset
	      (make_stringconst discr_verbatim_string "].")
	      (make_string discr_verbatim_string (get_field :ctype_argfield nctyp))
	      )))
	  (ocomp (instance 
		  class_objcompute
		  :obi_loc nloc
		  :obcpt_type nctyp
		  :obcpt_expr otuple))
	  )
      (debug "compilobj_nrep_variadic_argument ocomp=" ocomp)
      (return ocomp)
      )))
(install_method class_nrep_variadic_argument compile_obj compilobj_nrep_variadic_argument)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_consumevariadic (rcv gcx)
  (assert_msg "check rcv" (is_a rcv class_nrep_consume_variadic) rcv)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_consumevariadic rcv=" rcv)
  (let ( (nloc (unsafe_get_field :nrep_loc rcv))
	 (nvariadic (unsafe_get_field :nconsva_variadic rcv))
	 (nctypes (unsafe_get_field :nconsva_ctypes rcv))
	 (olist (make_list discr_list))
	 (ovariadicindex (variadic_index_idstr nvariadic))
	 (ovariadiclength (variadic_length_idstr nvariadic))
	 )
    (assert_msg "check nctypes" (is_multiple_or_null nctypes) nctypes)
    (list_append olist (make_stringconst discr_verbatim_string "/*consume variadic "))
    (foreach_in_multiple 
     (nctypes)
     (curctyp :long typix)
     (assert_msg "check curctyp" (is_a curctyp class_ctype) curctyp)
     (if (== curctyp ctype_value)
	 (list_append olist (make_stringconst discr_verbatim_string "Value"))
       (list_append olist (make_string discr_verbatim_string (get_field :named_name (get_field :ctype_keyword curctyp))))))
    (list_append olist (make_stringconst discr_verbatim_string " !*/ "))
    (list_append olist ovariadicindex)
    (list_append olist (make_stringconst discr_verbatim_string " += "))
    (list_append olist (make_integerbox discr_integer (multiple_length nctypes)))
    (let (
	  (otuple (list_to_multiple olist))
	  (ocomp (instance 
		  class_objcompute
		  :obi_loc nloc
		  :obcpt_type ctype_void
		  :obcpt_expr otuple))
	  )
      (debug "compilobj_nrep_consumevariadic ocomp=" ocomp)
      (return ocomp)
      )))
(install_method class_nrep_consume_variadic compile_obj compilobj_nrep_consumevariadic)

;;;;;;;;;;;;;
(defun putobjdest_objcond (recv desto)
  (assert_msg "check recv" (is_a recv class_objcond) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (othen (unsafe_get_field :obcond_then recv))
	 (oelse (unsafe_get_field :obcond_else recv)) 
	 )
    (let ( (dthen (put_objdest othen desto))
	   (delse (put_objdest oelse desto)) )
      (unsafe_put_fields recv
			 :obcond_then dthen
			 :obcond_else delse)
      recv
      )))

(install_method class_objcond  put_objdest  putobjdest_objcond)
;;;;;;;;;;;;;;;;

(defun compilobj_nrep_cppif (pif gcx)
  (assert_msg "check pif" (is_a pif class_nrep_cppif) pif)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (loc (unsafe_get_field :nrep_loc pif))
	 (ncond (unsafe_get_field :nifp_cond pif))
	 (nthen (unsafe_get_field :nifp_then pif))
	 (nelse (unsafe_get_field :nifp_else pif))
	 (ctyp (unsafe_get_field :nifp_ctyp pif))
	 (scond (cond
		 ( (is_a ncond class_symbol) (unsafe_get_field :named_name ncond))
		 ( (is_string ncond) ncond)
		 (:else (assert_msg "invalid ncond in nrep_cppif" () ncond))))
	 (othen (compile_obj nthen gcx))
	 (oelse (compile_obj nelse gcx))
	 (res (instance class_objcppif
			:obi_loc loc
			:obifp_cond scond
			:obifp_then othen
			:obifp_else oelse))
	 )
    (return res)
    ))
(install_method class_nrep_cppif compile_obj compilobj_nrep_cppif)


;;;;;;;;;;;;;
(defun putobjdest_objcppif (recv desto)
  (assert_msg "check recv" (is_a recv class_objcppif) recv)
  (assert_msg "check desto" (is_a desto class_objpurevalue) desto)
  (let ( (othen (unsafe_get_field :obifp_then recv))
	 (oelse (unsafe_get_field :obifp_else recv)) 
	 )
    (let ( (dthen (put_objdest othen desto))
	   (delse (put_objdest oelse desto)) )
      (unsafe_put_fields recv
			 :obifp_then dthen
			 :obifp_else delse)
      recv
      )))

(install_method class_objcppif  put_objdest  putobjdest_objcppif)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun compilobj_nrep_return (nret gcx)
  (assert_msg "check nret" (is_a nret class_nrep_return) nret)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_return nret=" nret "\n gcx=" gcx)
  (let ( (rloc (unsafe_get_field :nrep_loc nret))
	 (rmain (unsafe_get_field :nret_main nret))
	 (rrest (unsafe_get_field :nret_rest nret)) ;; a tuple or nil
	 (retloc (unsafe_get_field :gncx_retloc gcx))
	 (orout (unsafe_get_field :gncx_objrout gcx))
	 (olis (make_list discr_list))
	 (oblock (instance class_objplainblock
			   :obi_loc rloc
			   :oblo_bodyl olis))
	 (omainv (progn (debug "compilobj_nrep_return rmain=" rmain)
			(compile_obj rmain gcx)))
	 )
    (debug "compilobj_nrep_return omainv=" omainv)
    (assert_msg "check orout" (is_a orout class_routineobj) orout)
    (assert_msg "check rrest" (is_multiple_or_null rrest) rrest)
    (if (null (get_field :obrout_retval orout))
	(put_fields orout :obrout_retval retloc))
    (debug "compilobj_nrep_return omainv=" omainv " retloc=" retloc)
    (if retloc 
	(list_append olis (put_objdest omainv retloc)))
    (when (and (is_a orout class_initialroutineobj)
	       (>i (multiple_length rrest) 0))
      (debug "compilobj_nrep_return bad initial orout=" orout " with secondary results rrest=" rrest)
      (error_plain rloc "(RETURN ...) with secondary results outside of function")
      (return)
      )
    (debug "compilobj_nrep_return rrest=" rrest)
    (foreach_in_multiple
     (rrest)
     (rxtra :long ix)
     (debug "compilobj_nrep_return rxtra=" rxtra " ix=" ix)
     (let ( (oxres 
	     (instance class_objputxtraresult
		       :obi_loc rloc
		       :obxres_rank (make_integerbox discr_integer ix)
		       :obxres_obloc (compile_obj rxtra gcx))) 
	    )
       (debug "compilobj_nrep_return oxres=" oxres)
       ;; maybe we need to compute the ctype of the extra result....
       (list_append olis oxres)))
    ;; if no secondary results are returned, emit a check that no
    ;; secondary actual results are expected
    (if (is_a orout class_procroutineobj)
	(if (==i (multiple_length rrest) 0)
	    (let ( (ochecknores 
		    ;; I should be ashamed of this, we really should a
		    ;; special class subclass of class_objinstr for
		    ;; that check.
		    (make_objlocatedexp 
		     rloc ctype_void		
		     "/*ochecknores compilobj_nrep_return*/\n"
		     "#if MELT_HAVE_DEBUG\n"
		     " if (meltxresdescr_ && meltxresdescr_[0] && meltxrestab_)\n"
		     "    melt_warn_for_no_expected_secondary_results();\n"
		     "/* we warned when secondary results are expected but not returned. */\n"
		     "#endif /*MELT_HAVE_DEBUG*/\n"
		     ))
		   )
	      (debug "compilobj_nrep_return ochecknores=" ochecknores)
	      (list_append olis ochecknores)
	      )))
    (list_append olis 
		 (instance class_objfinalreturn
			   :obi_loc rloc))
    (debug "compilobj_nrep_return final oblock=" oblock)
    oblock
    ))
 
(install_method class_nrep_return compile_obj compilobj_nrep_return)

(install_method class_nrep_return get_ctype 
		(lambda (recv env) ctype_value))
;; all the closures generated by lambda share the same ...
(definstance discrclosure_objpredef class_objpredef
  :obv_type ctype_value
  :obpredef 'DISCR_CLOSURE
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_lambda (nlam gcx)
  (debug "compilobj_nrep_lambda nlam=" nlam "\n.. gcx=" gcx)
  (assert_msg "check nlam" (is_a nlam class_nrep_lambda) nlam)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (shortbacktrace_dbg "compilobj_nrep_lambda" 12)
  (let ( (nloc (unsafe_get_field :nrep_loc nlam))
	 (npro (let 
		   ( (checkpro (unsafe_get_field :nlambda_proc nlam)) )
		 (debug "compilobj_nrep_lambda npro=" checkpro)
		 (assert_msg "check checkpro" (is_a checkpro class_nrep_routproc) checkpro)
		 checkpro))
	 (nam (get_field :nrclop_name npro))
	 (nclovtup (unsafe_get_field :nlambda_closedv nlam))
	 (:long nbclosed (multiple_length nclovtup))
	 (locv (get_free_objlocptr gcx nam))
	 (nrou (unsafe_get_field :nlambda_constrout nlam))
	 (orout (unsafe_get_field :gncx_objrout gcx))
	 (olis (make_list discr_list))
	 (oblock (instance class_objplainblock
			   :obi_loc nloc
			   :oblo_bodyl olis))
	 (destlist (make_list discr_list))
	 )
    (debug "compilobj_nrep_lambda nrou=" nrou "\n.. npro=" npro "\n.. orout=" orout)
    (list_append destlist locv)
    (list_append olis 
		 (instance 
		  class_objnewclosure
		  :obi_loc nloc
		  :obnclo_discr discrclosure_objpredef
		  :obnclo_rout 
		  (progn 
		    (let ( (crou (compile_obj nrou gcx)) )
		      (debug "compilobj_nrep_lambda crou=" crou)
		      crou)
		    )
		  :obnclo_len (make_integerbox discr_integer nbclosed)
		  :obdi_destlist destlist))
    (foreach_in_multiple
     (nclovtup)
     (clov :long ix)
     (list_append 
      olis
      (instance class_objputclosedv
		:obi_loc nloc
		:opclov_clos locv
		:opclov_off (make_integerbox discr_integer ix)
		:opclov_cval (compile_obj clov gcx))))
    ;; we don't need to add any objtouch because the nlam was normalized!
    (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest
    (debug "compilobj_nrep_lambda result oblock=" oblock)
    oblock
    ))
(install_method class_nrep_lambda compile_obj compilobj_nrep_lambda)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_makeinst (nmki gcx)
  (debug "compilobj_nrep_makeinst nmki=" nmki)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check nmki" (is_a nmki class_nrep_instance) nmki)
  (let ( (nloc (unsafe_get_field :nrep_loc nmki))
	 (ncla (unsafe_get_field :nmins_class nmki))
	 (ncladat (unsafe_get_field :nmins_cladata nmki))
	 (nfields (unsafe_get_field :nmins_fields nmki)) 
	 )
    (assert_msg "check ncla" (is_a ncla class_class) ncla)
    (let ( (:long nbfld (multiple_length (unsafe_get_field :class_fields ncla)))
	   (destlist (make_list discr_list))
	   (locv (get_free_objlocptr gcx 'inst))
	   (olis (make_list discr_list))
	   (ocladat (compile_obj ncladat gcx))
	   (oblock (instance class_objplainblock
			     :obi_loc nloc
			     :oblo_bodyl olis))
	   (orallobj (instance class_objrawallocobj
			       :obi_loc nloc
			       :obrallobj_class ocladat
			       :obrallobj_len (make_integerbox discr_integer nbfld)
			       :obrallobj_classname (unsafe_get_field :named_name  ncla)
			       :obdi_destlist destlist))
	   )
      (list_append destlist locv)
      (list_append olis orallobj)
      ;; handle each field assign
      (foreach_in_multiple
       (nfields)
       (cfla :long ix)
       (assert_msg "compilobj_nrep_makeinst check cfla" (is_a cfla class_nrep_fieldassign) cfla)
       (let ( (cfloc (unsafe_get_field :nrep_loc cfla))
	      (cfield (unsafe_get_field :nfla_field cfla))
	      (cval (unsafe_get_field :nfla_val cfla)) )
	 (assert_msg "compilobj_nrep_makeinst check cfield" (is_a cfield class_field) cfield)
	 (let ( (oval (compile_obj cval gcx)) 
		(oputs (instance class_objputslot 
				 :obi_loc (if cfloc cfloc nloc)
				 :oslot_odata locv
				 :oslot_field cfield
				 :oslot_offset (make_integerbox discr_integer (get_int cfield))
				 :oslot_value oval))
		)
	   (debug "compilobj_nrep_makeinst cval=" cval "\n.. oputs=" oputs)
	   (assert_msg "compilobj_nrep_makeinst check oval not nrep" (not (is_a oval class_nrep)) oval)
	   (list_append olis oputs)
	   )))
      ;; since nmki was normalized, the new object was allocated in
      ;; the birth zone so don't need to be touched.  
      ;; 
      ;; add the debugtracing
      (let ( (odbgtr (instance class_objdbgtracewriteobj
			       :obi_loc nloc
			       :obdtw_writtenobj locv
			       :obdtw_message '"newly made instance"
			       ))
	     )
	(list_append olis odbgtr)
	)
      (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest
      (debug "compilobj_nrep_makeinst result oblock=" oblock)
      oblock
      )))
  
(install_method class_nrep_instance compile_obj compilobj_nrep_makeinst)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; compile a procedure should not be called
(defun compilobj_routproc (npro gcx)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check npro" (is_a npro class_nrep_routproc) npro)
  (debug "compilobj_routproc npro=" npro "\n... gcx=" gcx)
  (assert_msg "UNEXPECTED CALL TO compilobj_routproc" () npro)
  )
(install_method class_nrep_routproc compile_obj compilobj_routproc)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(defun compilobj_predef (npr gcx)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check npr" (is_a npr class_nrep_predef) npr)
  (let ((obpred (get_field :nrpredef npr))
	(opr (instance class_objpredef
			:obv_type ctype_value
			:obpredef obpred)) 
	)
    (assert_msg "check obpred" obpred npr)
    opr)
  )

(install_method class_nrep_predef compile_obj compilobj_predef)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; common code to compilobj_datasymbol & compilobj_datainstance
;;; to add the initial data fill and the slots filling
;;; return a tuple of bindings to be disposed
(defun compil_data_and_slots_fill (ndat obj odiscr irout gcx)
  (debug "compil_data_and_slots_fill start ndat=" ndat 
	 "\n.. obj=" obj 
	 "\n.. odiscr=" odiscr 
	 "\n.. irout=" irout "\n")
  (shortbacktrace_dbg "compil_data_and_slots_fill" 25)
  (assert_msg "compil_data_and_slots_fill check ndat" (is_a ndat class_nrep_bound_data) ndat)
  (assert_msg "compil_data_and_slots_fill check obj" (is_a obj class_objinitobject) obj)
  (assert_msg "compil_data_and_slots_fill check odiscr" (is_a odiscr class_objvalue) odiscr)
  (assert_msg "compil_data_and_slots_fill check irout" (is_a irout class_any_start_routineobj) irout)
  (assert_msg "compil_data_and_slots_fill check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(ipredef 
	 (cond
	   ( (is_a ndat class_nrep_datainstance) 
	     (unsafe_get_field :ninst_predef ndat))
	   ( (is_a ndat class_nrep_datahook)
	     (unsafe_get_field :ndhook_predef ndat))))
	(ibodylis (get_field :obrout_body irout))
	(locvar (get_free_objlocptr gcx '_valdata_))
	(comm (unsafe_get_field :named_name '_valuedata_))
	(nloc (unsafe_get_field :nrep_loc ndat))
	(dlocbind (unsafe_get_field :ndata_locbind ndat))
	(locmap (unsafe_get_field :gncx_locmap gcx))
	(istmtlis ibodylis) ;the statement list to which the putslots are appended
	;; a tuple to store the objvar for localbinds to be able to clear them later
	(tupvar (make_multiple discr_multiple (multiple_length locmap)))
	)
    (assert_msg "compil_data_and_slots_fill check ibodylis" (is_list ibodylis) ibodylis)
    (assert_msg "compil_data_and_slots_fill check fresh obj" (null (unsafe_get_field :oie_locvar obj)) obj)
    (unsafe_put_fields obj :oie_locvar locvar)
    (debug "compil_data_and_slots_fill updated obj=" obj)
    ;; if the data is predefined, we fill it conditionally on !meltpredefinited[..]
    (if ipredef
	(let ( 
	      (otestpredef 
	       (cond 
		( (is_a ipredef class_symbol)
		  (instance 
		   class_objexpv
		   :obx_cont (tuple
			      (make_stringconst discr_verbatim_string 
						"MELTPREDEFIX(meltpredefinited,")
			      (make_string discr_verbatim_string 
					   (unsafe_get_field :named_name ipredef))
			      (make_stringconst discr_verbatim_string 
						")")
			      ))
		  )
		( (is_integerbox ipredef)
		  (instance
		   class_objexpv
		   :obx_cont (tuple
			      (make_stringconst discr_verbatim_string 
						"predefinited[")
			      ipredef
			      (make_stringconst discr_verbatim_string 
						"]")
			      ))
		  )
		))
	      (initlis (make_list discr_list))
	      (oblockpredef (instance 
			     class_objcommentedblock
			     :oblo_bodyl initlis
			     :ocomblo_comment '"fill predef slots"))
	      (ocondpredef (instance
			    class_objcond
			    :obi_loc nloc
			    :obcond_test otestpredef
			    :obcond_then ()
			    :obcond_else oblockpredef))
	      )
	  (setq istmtlis initlis)
	  (list_append ibodylis ocondpredef)
	  ))
    (debug "compil_data_and_slots_fill dlocbind=" dlocbind)
    (foreach_in_multiple
     (dlocbind)
     (lbind :long bindrk)
     (debug "compil_data_and_slots_fill lbind=" lbind)
     (assert_msg "compil_data_and_slots_fill check lbind" (is_a lbind class_normal_let_binding) lbind)
     (let ( (bder (unsafe_get_field :binder lbind))
	    (cty (unsafe_get_field :letbind_type lbind))
	    (nexp (unsafe_get_field :letbind_expr lbind))
	    (obva (get_free_objloctyped gcx bder cty))
	    (obnx (compile_obj nexp gcx)) 
	    )
       (debug "compil_data_and_slots_fill obnx=" obnx "\n.. obva=" obva)
       (if obva (mapobject_put locmap lbind obva))
       (let ( (obmy (if obva (put_objdest obnx obva) obnx)) )
	 ;; add the modified obmy in the ibodylis
	 (list_append istmtlis obmy)
	 )
       (if obva (multiple_put_nth tupvar bindrk obva))
       ))
    (shortbacktrace_dbg "compil_data_and_slots_fill [slo]" 21)
    (debug "compil_data_and_slots_fill ndats slots="
	   (get_field :ninst_slots ndat))
    ;; for every non nil slot, append its initialization to istmtlis
    (foreach_in_multiple
     ((unsafe_get_field :ninst_slots ndat))
     (sloval :long slork)
     (if sloval
;;; add to list inifill the filling in dai of slot#slork by slobj
	 (let ( (slobj (compile_obj sloval gcx)) 
		)
	   (debug "compil_data_and_slots_fill slobj=" slobj "\n.. sloval=" sloval "\n slork#" slork)
	   (assert_msg "compil_data_and_slots_fill check slobj not nrep" (is_not_a slobj class_nrep) slobj)
	   (let (
		 (ooff (make_integerbox discr_integer slork))
		 (oput (instance class_objputslot
				 :obi_loc  nloc
				 :oslot_odata obj
				 :oslot_offset ooff
				 :oslot_value slobj
				 )) 
		 )
	     (debug "compil_data_and_slots_fill oput=" oput "\n for sloval=" sloval)
	     (shortbacktrace_dbg "compil_data_and_slots_fill oput" 18)
	     (list_append istmtlis oput)
	     ))))
    ;; touch the object
    (list_append istmtlis 
		 (instance class_objtouch
			   :obi_loc (if nloc nloc (unsafe_get_field :nrep_loc ndat))
			   :otouch_comment comm
			   :otouch_val obj))
    ;; debugwrite the object		;
    (list_append istmtlis
    (instance class_objdbgtracewriteobj
    :obi_loc (if nloc nloc (unsafe_get_field :nrep_loc ndat))
    :obdtw_writtenobj obj
    :obdtw_message '"new static instance"))
    ;; for every non nil local obvar, clear it
    (multiple_every
     tupvar
     (lambda (obva :long ix)
       (if obva
	   (progn
	     (list_append ibodylis
			  (instance class_objclear 
				    :obi_loc nloc
				    :oclr_vloc obva))
	     ))))
;;; add the obj as the last instr of the block
    (list_append ibodylis obj)
    ;;
    (debug "compil_data_and_slots_fill final dlocbind=" dlocbind)
    ;; the caller is supposed to do
    ;; dispose_dlocbind_after_data_and_slots_fill with the result if
    ;; needed but in practice this is never needed
    (return dlocbind)
    )
  (return)				;force a nil return
  )


;; probably useless function
(defun dispose_dlocbind_after_data_and_slots_fill (dlocbind gcx)
  (debug "dispose_dlocbind_after_data_and_slots_fill dlocbind=" dlocbind)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (multiple_every
   dlocbind
   (lambda (bnd :long ix) (dispose_bnd_obj bnd gcx)))
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_datasymbol (syv gcx)
  (debug "compilobj_datasymbol syv=" syv)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check syv" (is_a syv class_nrep_datasymbol) syv)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (chobj (mapobject_get compicache syv))
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 )
    (debug "compilobj_datasymbol inirout=" inirout 
	   "\n compicache=" compicache "\n chobj=" chobj)
    ;; datasymbol compiled only in start routines
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug "compilobj_datasymbol found chobj=" chobj)
      (return chobj))
    (let (
	  (odiscr  (compile_obj (unsafe_get_field :ndata_discrx syv) gcx))
	  (obsym 
	   ;;; symbols should be unique objects, to avoir recreating
	   ;;; them when they already exist.
	   (instance class_objinituniqueobject
		     :obv_type ctype_value
		     :oie_data syv
		     :oie_discr odiscr
		     :oie_cname ()
		     :oio_class ()
		     )) 
	  )
      (mapobject_put compicache syv obsym)
      (debug "compilobj_datasymbol obsym=" obsym  "\n.. syv=" syv 
	     "\n.. updated compicache=" compicache "\n")
      ;; make a cname
      (let ( (nambuf (make_strbuf discr_strbuf))
	     (:long syrk (get_int (unsafe_get_field :ndata_rank syv)))
	     )
	(add2sbuf_strconst nambuf "dsym_")
	(add2sbuf_longdec nambuf syrk)
	(add2sbuf_strconst nambuf "__")
	(add2sbuf_cident nambuf (unsafe_get_field :ndsy_namestr syv))
	(unsafe_put_fields obsym
			   :oie_cname (strbuf2string discr_string nambuf)))
      (shortbacktrace_dbg "compilobj_datasymbol" 6)
      (debug "compilobj_datasymbol obsym=" obsym "\n.. for syv=" syv)
      ;; put the length as obj_num of obsym
      (put_int obsym (multiple_length (unsafe_get_field :ninst_slots syv)))
      (let ( (dlocbind (compil_data_and_slots_fill syv obsym odiscr inirout gcx)) ) 
	(debug "compilobj_datasymbol dlocbind=" dlocbind)
	;;(dispose_dlocbind_after_data_and_slots_fill dlocbind gcx)
	)
      (shortbacktrace_dbg "compilobj_datasymbol" 9)
      (debug "compilobj_datasymbol final obsym=" obsym)
      (return obsym)
      )))
(install_method class_nrep_datasymbol compile_obj compilobj_datasymbol)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; compilobj of datainstance
(defun compilobj_datainstance (dai gcx)
  (debug "compilobj_datainstance dai=" dai)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (chobj (mapobject_get compicache dai))
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 )
    ;; datainstance compiled only in start routine
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug "compilobj_datainstance return found chobj=" chobj)
      (return chobj))
    (let ( (loc (unsafe_get_field :nrep_loc dai))
	   (nam (unsafe_get_field :ndata_name dai))
	   ;; nam is a symbol, not a string
	   (disx (unsafe_get_field :ndata_discrx dai))
	   (drank (unsafe_get_field :ndata_rank dai))
	   (dhash (unsafe_get_field :ninst_hash dai))
	   (dpredef (unsafe_get_field :ninst_predef dai))
	   (dslots (unsafe_get_field :ninst_slots dai)) 
	   )
      ;; if the drank is invalid or nil, the data has never been added
      ;; with add_nctx_data (should not happen)
      (assert_msg "compilobj_datainstance check drank" (is_integerbox drank) drank)
      (let ( (cdisx (compile_obj disx gcx)) 
	     )
	(debug "compilobj_datainstance cdisx=" cdisx)
	(let (
	      ;; make a cname
	      (oini (if dpredef ;; if predefined, make it unique!
			(instance class_objinituniqueobject
			      :obv_type ctype_value
			      :oie_data dai
			      :oie_discr cdisx
			      :oio_predef dpredef
			      :oio_class ()
			      )
		      ;; othewise, don't bother make it unique
			(instance class_objinitobject
			      :obv_type ctype_value
			      :oie_data dai
			      :oie_discr cdisx
			      :oio_predef dpredef
			      :oio_class ()
			      )
		      ))
	      (nambuf (make_strbuf discr_strbuf))
	      (:long drk (get_int drank))
	      )
	  (debug "compilobj_datainstance oini=" oini)
	  (shortbacktrace_dbg "compilobj_datainstance" 14)
	  (mapobject_put compicache dai oini)
	  (debug "compilobj_datainstance updated compicache=" compicache 
		 "\n.. dai=" dai "\n.. oini=" oini)
	  (add2sbuf_strconst nambuf "dobj_")
	  (add2sbuf_longdec nambuf drk)
	  (if nam (progn
		    (add2sbuf_strconst nambuf "__")
		    (add2sbuf_cident nambuf (get_field :named_name nam))))
	  (let ( (cnam (strbuf2string discr_string nambuf)) )
	    (unsafe_put_fields oini :oie_cname cnam)
	    )
	  (put_int oini (multiple_length dslots))
	  (let ( (dlocbind (compil_data_and_slots_fill dai oini cdisx inirout gcx)) )
	    (debug "compil_data_and_slots_fill dlocbind=" dlocbind)
	    ;;(dispose_dlocbind_after_data_and_slots_fill dlocbind gcx)
	    )
	  (debug "compilobj_datainstance final oini=" oini)
	  (return oini)
	  )  
	)
      )
    )
  )
(install_method class_nrep_datainstance compile_obj compilobj_datainstance)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; compile a data tuple
(defun compilobj_datatuple (nti gcx)
  (debug "compilobj_datatuple nti=" nti)
  (assert_msg "check nti" (is_a nti class_nrep_datatuple) nti)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (chobj (mapobject_get compicache nti))
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 )
    ;; datatuples compiled only in start routine
    (debug "compilobj_datatuple inirout=" inirout)
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug "compilobj_datatuple found chobj=" chobj)
      (return chobj))
    (let ( (ncompi (unsafe_get_field :ntup_comp nti))
	   (ocompi (multiple_map 
		    ncompi
		    (lambda (c :long ix) (if c (compile_obj c gcx)))))
	   (disx (unsafe_get_field :ndata_discrx nti))
	   (drank (unsafe_get_field :ndata_rank nti))
	   (odiscr (compile_obj disx gcx)) 
	   (nam (unsafe_get_field :ndata_name nti))
	   (nambuf (make_strbuf discr_strbuf))
	   (locvar (get_free_objlocptr gcx '_valtup_))
	   (:long drk (get_int drank))
	   (inibody (get_field :obrout_body inirout))
	   (comm (unsafe_get_field :named_name '_initup_))
	   )
      (add2sbuf_strconst nambuf "dtup_")
      (add2sbuf_longdec nambuf drk)
      (cond 
       ((is_a nam class_symbol)
	(add2out nambuf "_sy" (symbol_cname nam)))
       ((is_a nam class_named)
	(add2sbuf_strconst nambuf "__")
	(add2sbuf_cident nambuf (get_field :named_name nam)))
       ((is_string nam)
	(add2out nambuf "___") (add2sbuf_cident nambuf nam)))
      (let ( (otup (instance class_objinitmultiple
			     :obv_type ctype_value
			     :oie_discr odiscr
			     :oie_locvar locvar
			     :oie_cname (strbuf2string discr_verbatim_string nambuf)
			     :oim_tupval ocompi
			     ))
	     )
	(mapobject_put compicache nti otup)
	(debug "compilobj_datatuple updated compicache=" compicache
	       "\n.. nti=" nti "\n.. otup=" otup)
	(put_int otup (multiple_length ncompi))
	(multiple_every
	 ncompi
	 (lambda (scomp :long srk)
	   (if scomp 
	       (let ( (ocomp (multiple_nth ocompi srk)) )
		 (list_append inibody
			      (instance class_objputuple
					:oputu_tupled otup
					:oputu_offset (make_integerbox discr_integer srk)
					:oputu_value ocomp)))
	     )))
	(list_append inibody
		     (instance class_objtouch
			       :otouch_val otup
			       :otouch_comment comm))
	(debug "compilobj_datatuple otup=" otup)
	(return otup)
	)
      )
    )
  )

(install_method class_nrep_datatuple compile_obj compilobj_datatuple)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; compile a data string
(defun compilobj_datastring (nds gcx)
  (assert_msg "check nds" (is_a nds class_nrep_datastring) nds)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 (chobj (mapobject_get compicache nds))
	 )
    ;; datastring compiled only in initial routines
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (if chobj
	(progn
	  (return chobj)))
    (let (
	  (nambuf (make_strbuf discr_strbuf))
	  (ndisx (unsafe_get_field :ndata_discrx nds))
	  (odiscr (compile_obj ndisx gcx))
	  (odata (unsafe_get_field :nstr_string nds))
	  (drank (unsafe_get_field :ndata_rank nds))
	  (nam (unsafe_get_field :ndata_name nds))
	  (locvar (get_free_objlocptr gcx '_valstr_))
	  (:long drk (get_int drank))
	  (ostr (instance class_objinitstring
			  :obv_type ctype_value
			  :oie_data odata
			  :oie_discr odiscr
			  :oie_locvar locvar
			  )) 
	  )
      (mapobject_put compicache nds ostr)
      (debug "compilobj_datastring updated compicache=" compicache
	     "\n.. nds=" nds "\n.. ostr=" ostr)
      (add2sbuf_strconst nambuf "dstr_")
      (add2sbuf_longdec nambuf drk)
      (add2sbuf_strconst nambuf "__")
      (add2sbuf_cidentprefix nambuf odata 24)
      (put_int ostr (string_length odata))
      (if nam 
	  (progn
	    (add2sbuf_strconst nambuf "__")
	    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
      (unsafe_put_fields ostr :oie_cname (strbuf2string discr_string nambuf))
      ostr
      )
    ))
(install_method class_nrep_datastring compile_obj compilobj_datastring)

;;;;;;;;;;;;;;;; compile a data boxed integer
(defun compilobj_databoxedinteger (ndi gcx)
  (debug "compilobj_databoxedinteger ndi=" ndi)
  (assert_msg "check ndi" (is_a ndi class_nrep_databoxedinteger) ndi)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 (chobj (mapobject_get compicache ndi))
	 )
    ;; datastring compiled only in initial routines
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug "compilobj_databoxedinteger found chobj=" chobj)
      (return chobj))
    (let (
	  (nambuf (make_strbuf discr_strbuf))
	  (ndisx (unsafe_get_field :ndata_discrx ndi))
	  (odiscr (compile_obj ndisx gcx))
	  (odata (unsafe_get_field :nboxint_num ndi))
	  (drank (unsafe_get_field :ndata_rank ndi))
	  (nam (unsafe_get_field :ndata_name ndi))
	  (locvar (get_free_objlocptr gcx '_valbxint_))
	  (:long drk (get_int drank))
	  (oint (instance class_objinitboxinteger
			  :obv_type ctype_value
			  :oie_data odata
			  :oie_discr odiscr
			  :oie_locvar locvar
			  )) 
	  )
      (mapobject_put compicache ndi oint)
      (debug "compilobj_databoxedinteger updated compicache=" compicache "\n ndi=" ndi "\n.. oint=" oint)
      (add2sbuf_strconst nambuf "dint_")
      (add2sbuf_longdec nambuf drk)
      (add2sbuf_strconst nambuf "__")
      (add2sbuf_cidentprefix nambuf odata 16)
      (if nam 
	  (progn
	    (add2sbuf_strconst nambuf "__")
	    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
      (unsafe_put_fields oint :oie_cname (strbuf2string discr_string nambuf))
      oint
      )
    ))
(install_method class_nrep_databoxedinteger compile_obj compilobj_databoxedinteger)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; compile a data closure
(defun compilobj_dataclosure (ncl gcx)
  (debug "compilobj_dataclosure ncl=" ncl)
  (assert_msg "check ncl" (is_a ncl class_nrep_dataclosure) ncl)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 (inibody (unsafe_get_field :obrout_body inirout))
	 (chobj (mapobject_get compicache ncl))
	 )
    (assert_msg  "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug  "compilobj_dataclosure found chobj=" chobj)
      (return chobj))
    (let ( 
	  (nam (unsafe_get_field :ndata_name ncl))
	  (discx (unsafe_get_field :ndata_discrx ncl))
	  (nrank (unsafe_get_field :ndata_rank ncl))
	  (nloc (unsafe_get_field :nrep_loc ncl))
	  (npro (unsafe_get_field :ndclo_proc ncl))
	  (nclov (unsafe_get_field :ndclo_closv ncl))
	  (:long nbclos (multiple_length nclov))
	  (nambuf (make_strbuf discr_strbuf))
	  (odiscr (compile_obj discx gcx))
	  (locvar (get_free_objlocptr gcx '_valclo_))
	  (comm (unsafe_get_field :named_name '_dataclosure_))
	  )
      (assert_msg "check npro" (is_a npro class_nrep_routproc) npro)
      (add2sbuf_strconst nambuf "dclo_")
      (add2sbuf_longdec nambuf (get_int nrank))
      (when nam
	(add2sbuf_strconst nambuf "__")
	(add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
      (let (
	    (ndatarou (unsafe_get_field :nrpro_datarout npro))
	    (oiclo
	     (instance class_objinitclosure
		       :obv_type ctype_value
		       :oie_discr odiscr
		       :oie_data ncl
		       :oie_locvar locvar
		       :oie_cname (strbuf2string discr_string nambuf)
		       )) 
	    )
	(put_int oiclo nbclos)
	(mapobject_put compicache ncl oiclo)
	(debug  "compilobj_dataclosure updated compicache=" compicache
		"\n.. ncl=" ncl "\n.. oiclo=" oiclo)
	(assert_msg "check ndatarou" (is_a ndatarou class_nrep_dataroutine) ndatarou)
	(let (
	      ;; npro should already have been compiled, so should be in the compiler cache
	      (ocrout (mapobject_get compicache npro))
	      (odatrout (compile_obj ndatarou gcx))
	      (ocputrout (instance  class_objputclosurout
				    :obi_loc nloc
				    :opclor_clos oiclo
				    :opclor_rout odatrout
				    ;;@@OLDBUGGY :opclor_rout (mapobject_get compicache ndatarou)
				    ))
	      (bxoff (make_integerbox discr_integer 0))
	      )
	  (assert_msg "check ocrout" (is_a ocrout class_procroutineobj) ocrout)
	  (list_append inibody ocputrout)
	  (multiple_every
	   nclov
	   (lambda (clov :long ix)
	     (let ( (cloval (compile_obj clov gcx)) 
		    (ocputclos (instance class_objputclosedv
					 :obi_loc nloc
					 :opclov_clos oiclo
					 :opclov_off (make_integerbox discr_integer (get_int bxoff))
					 :opclov_cval cloval))
		    )
	       (list_append inibody ocputclos)
	       )
	     (put_int bxoff (+i (get_int bxoff) 1))))
	  (list_append inibody (instance class_objtouch
					 :obi_loc nloc
					 :otouch_comment comm
					 :otouch_val oiclo))
	  oiclo
	  ))
      ))
  )
(install_method class_nrep_dataclosure compile_obj compilobj_dataclosure)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; compile a data routine
(defun compilobj_dataroutine (ndrou gcx)
  (debug "compilobj_dataroutine ndrou=" ndrou "\n.. gcx=" gcx)
  (shortbacktrace_dbg "compilobj_dataroutine" 16)
  (assert_msg "check ndrou" (is_a ndrou class_nrep_dataroutine) ndrou)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 (chobj (mapobject_get compicache ndrou))
	 )
    ;; dataroutine compiled only in initial routines
    (debug "compilobj_dataroutine" " inirout=" inirout)
    (shortbacktrace_dbg "compilobj_dataroutine" 10)
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (when chobj
      (debug "compilobj_dataroutine return chobj=" chobj)
      (return chobj))
    (let ( (nam (unsafe_get_field :ndata_name ndrou))
	   (disx (unsafe_get_field :ndata_discrx ndrou))
	   (nloc (unsafe_get_field :nrep_loc ndrou))
	   (drank (unsafe_get_field :ndata_rank ndrou))
	   (nam (unsafe_get_field :ndata_name ndrou))
	   (npro (get_field :ndrou_proc ndrou))
	   (inibody (get_field :obrout_body inirout))
	   (locvar (get_free_objlocptr gcx '_valrout_))
	   )
      (debug "compilobj_dataroutine" " npro=" npro "\n.. ndrou=" ndrou)
      (if (null nloc)
	  (if (is_a npro class_nrep)
	      (setq nloc (unsafe_get_field :nrep_loc npro))))
      (debug "compilobj_dataroutine compicache=" compicache)
      (assert_msg "check compicache" (is_mapobject compicache) compicache)
      (let (
	    (nambuf (make_strbuf discr_strbuf))
	    (:long drk (get_int drank))
	    (odiscr (compile_obj disx gcx))
	    )
	(add2sbuf_strconst nambuf "drout_")
	(add2sbuf_longdec nambuf drk)
	(when nam
	  (add2sbuf_strconst nambuf "__")
	  (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
	(let (
	      (oinipro (mapobject_get compicache npro))
	      (oirout 
	       (instance class_objinitroutine
			 :obv_type ctype_value
			 :oie_discr odiscr
			 :oie_data ndrou
			 :oie_locvar locvar
			 :oie_cname (strbuf2string discr_string nambuf)
			 :oir_procroutine oinipro
			 )) 
	      )
	  (debug "compilobj_dataroutine oirout=" oirout "\n .. oinipro=" oinipro
		 "\n.. npro=" npro "\n.. compicache=" compicache
		 "\n.. ndrou=" debug_less ndrou)
	  (assert_msg "check oinipro" (is_object oinipro) oinipro npro compicache ndrou)
	  (mapobject_put compicache ndrou oirout)
	  (debug "compilobj_dataroutine updated compicache=" compicache 
		 "\n.. ndrou=" ndrou "\n.. oirout=" oirout)
	  (if (is_a npro class_nrep_routproc)
	      (let ( (pconstl (get_field :nrclop_constlist npro)) 
		     (:long nbconst (list_length pconstl))
		     (bxoff (make_integerbox discr_integer 0))
		     (comm (unsafe_get_field :named_name '_iroutval_))
		     )
		(debug "compilobj_dataroutine pconstl=" pconstl)
		(put_int oirout nbconst)
		(foreach_pair_component_in_list
		 (pconstl)
		 (constpair constx)
		 (debug "compilobj_dataroutine constx=" constx)
		 (cond
		  ( (is_a constx class_nrep_constocc)
		    (let ( (cnstbind (unsafe_get_field :nocc_bind constx)) )
		      (assert_msg "compilobj_dataroutine check cnstbind" (is_a cnstbind class_any_binding) cnstbind)
		      (let ( 
			    (oconstx (compile_obj cnstbind gcx)) 
			    (:long off (get_int bxoff))
			    ) 
			(debug "compilobj_dataroutine oconstx=" oconstx "\n.. off=" off)
			(if oconstx 
			    (let (
				  (iput
				   (if (is_a cnstbind class_fixed_binding)
				       (instance class_objputroutconstnotnull
						 :obi_loc nloc
						 :oprconst_rout oirout
						 :oprconst_off (make_integerbox discr_integer off)
						 :oprconst_cval oconstx)
				     (instance class_objputroutconst
					       :obi_loc nloc
					       :oprconst_rout oirout
					       :oprconst_off (make_integerbox discr_integer off)
					       :oprconst_cval oconstx)
				     )) 
				  ) 
			      (list_append inibody iput)
			      (put_int bxoff (+i off 1))))))
		    )
		  ( (is_a constx class_nrep_quasidata)
		    (let ( 
			  (oconstx (compile_obj constx gcx)) 
			  (:long off (get_int bxoff))
			  ) 
		      (if oconstx 
			  (let ( (iput (instance class_objputroutconst
						 :obi_loc nloc
						 :oprconst_rout oirout
						 :oprconst_off (make_integerbox discr_integer off)
						 :oprconst_cval oconstx)) ) 
			    (list_append inibody iput)
			    (put_int bxoff (+i off 1))))))
		  (:else
		   (assert_msg "compilobj_dataroutine uneppected constx" () constx)
		   )
		  )
		 ) 			;end foreach_pair_component_in_list pconstl
		(if (>i (get_int bxoff) 0)
		    (list_append inibody (instance class_objtouch
						   :obi_loc nloc
						   :otouch_val oirout
						   :otouch_comment comm
						   )))
		(debug "compilobj_dataroutine final oirout=" oirout)
		oirout)
	    ))))
    )
  )
(install_method class_nrep_dataroutine compile_obj compilobj_dataroutine)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_datahook (ndhook gcx)
  (debug "compilobj_datahook ndhook=" ndhook "\n.. gcx=" gcx "\n")
  (shortbacktrace_dbg "compilobj_datahook" 16)
  (assert_msg "check ndhook" (is_a ndhook class_nrep_datahook) ndhook)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
	 (inirout (unsafe_get_field :gncx_objrout gcx))
	 (chobj (mapobject_get compicache ndhook))
	 (nloc (get_field :nrep_loc ndhook))
	 )
    (debug "compilobj_datahook compicache=" compicache)
    (assert_msg "check compicache" (is_mapobject compicache) compicache)
    (when chobj
      (debug "compilobj_datahook return chobj=" chobj)
      (return chobj))
    (debug "compilobj_datahook inirout=" inirout)
    (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout)
    (let ( 
	  (nclotup (let ( (nct (get_field :ndhook_closv ndhook)) )
		     (debug "compilobj_datahook nclotup=" nct)
		     nct))
	  (inibody (get_field :obrout_body inirout))
	  (:long nbclo (multiple_length nclotup))
	  (nhpro (get_field :ndhook_proc ndhook))
	  (hname (get_field :ndata_name ndhook))      ;a string
	  (nrank (get_field :ndata_rank ndhook))      ;a boxed int
	  (npredef (get_field :ndhook_predef ndhook)) ;a symbol or nil
	  (nmodvarbind (get_field :ndhook_modvarbind ndhook)) 
					;a normal module variable binding or nil
	  (nlocbind (get_field :ndata_locbind ndhook))
	  (ndisx (get_field :ndata_discrx ndhook))
	  (ndhdata (get_field :ndhook_data ndhook))
	  (odiscr (let ( (odi (compile_obj ndisx gcx)) )
		    (debug "compilobj_datahook odiscr=" odi)
		    odi))
	  (onam (string4out discr_verbatim_string
			    ##{dhook__$NRANK#__$HNAME}#))
	  (locvar (get_free_objlocptr gcx '_valhook_))
	  (oclo (make_multiple discr_multiple nbclo))
	  (ohkdata (let ( (o (compile_obj ndhdata gcx))
			  )
		     (debug "compilobj_datahook ohkdata=" o)
		     o))
	  (oihook 
	   (instance class_objinithook
		     :obv_type ctype_value
		     :oie_locvar locvar
		     :oie_cname onam
		     :oie_data ndhook
		     :oie_discr odiscr
		     :oihk_data ohkdata
		     :oihk_prochook nhpro
		     :oihk_cloval oclo
		     :oihk_predef npredef
		     :oihk_modvarbind nmodvarbind
		     ))
	  )
      (debug "compilobj_datahook before compiling nclotup=" nclotup)
      (foreach_in_multiple
       (nclotup)
       (ncurclo :long clix)
       (debug "compilobj_datahook clix#" clix " ncurclo=" ncurclo)
       (let ( (ocurclo (compile_obj ncurclo gcx))
	      )
	 (debug "compilobj_datahook clix#" clix " ocurclo=" ocurclo)
	 (multiple_put_nth oclo clix ocurclo)
	 ))
      (debug "compilobj_datahook oclo=" oclo)
      (mapobject_put compicache ndhook oihook)
      (put_int oihook (multiple_length oclo))
      (debug "compilobj_datahook updated compicache=" compicache 
	     "\n.. nclotup=" nclotup "\n.. nhpro=" nhpro
	     "\n.. oihook=" oihook
	     "\n.. oclo=" oclo "\n.. inibody=" inibody)
      (when nmodvarbind
	(assert_msg "check nmodvarbind" (is_a nmodvarbind class_normal_module_variable_binding) nmodvarbind)
	(let ( (opmv (instance class_objputmodvar
			       :obi_loc nloc
			       :obputmodvar_bind nmodvarbind
			       :obputmodvar_val oihook
			       ))
	       )
	  (list_append inibody opmv)
	  (debug "compilobj_datahook opmv=" opmv)
	  ))
      ;; set the data
      (let ( (ophd (instance class_objputhookdata
			     :obi_loc nloc
			     :ophkdata_hook oihook
			     :ophkdata_data ohkdata))
	     )
	(list_append inibody ophd)
	(debug "compilobj_datahook ophd=" ophd))
      ;; set the components
      (debug "compilobj_datahook oclo=" oclo)
      (foreach_in_multiple
       (oclo)
       (curobc :long obix)
       (debug "compilobj_datahook curobc=" curobc "   obix#" obix)
       (let ( 
	     (iput (instance class_objputhookconst
			     :obi_loc nloc
			     :ophconst_hook oihook
			     :ophconst_off (constant_box obix)
			     :ophconst_cval curobc
			     ))
	     )
	 (debug "compilobj_datahook obix=" obix ".. curobc=" curobc
		"\n.. iput=" iput)
	 (list_append inibody iput)
	 ))
      (when (multiple_length oclo)
	(list_append inibody (instance class_objtouch
				       :obi_loc nloc
				       :otouch_val oihook
				       :otouch_comment hname
				       )))
      (debug "compilobj_datahook updated inibody=" inibody "\n.. final oihook=" oihook "\n")
      (return oihook)
      )))

(install_method class_nrep_datahook compile_obj compilobj_datahook)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_quasidata_current_module_environment_reference (qdcm gcx)
  (assert_msg "check qdcm" (is_a qdcm class_nrep_quasidata_current_module_environment_reference) qdcm)
  ;; the get_field below will fail if gcx is not a  class_initial_generation_context
  (let ( (locbox (get_field :igncx_contenvloc gcx)) 
	 )
    (return locbox)))
(install_method class_nrep_quasidata_current_module_environment_reference compile_obj compilobj_quasidata_current_module_environment_reference)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_quasidata_parent_module_environment (qdpm gcx)
  (debug "compilobj_quasidata_parent_module_environment qdpm=" qdpm " gcx=" gcx)
  (assert_msg "check qdpm" (is_a qdpm class_nrep_quasidata_parent_module_environment) qdpm)
  ;; the get_field below will fail if gcx is not a  class_initial_generation_context
  (let ( (prevenvloc (get_field :igncx_prevenvloc gcx)) 
	 )
    (return prevenvloc)))
(install_method class_nrep_quasidata_parent_module_environment compile_obj compilobj_quasidata_parent_module_environment)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_store_predefined (nspr gcx)
  (assert_msg "check nspr" (is_a nspr class_nrep_store_predefined) nspr)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "compilobj_nrep_store_predefined start nspr=" nspr)
  (let ( (nloc (unsafe_get_field :nrep_loc nspr))
	 (npred (unsafe_get_field :nstpd_predef nspr))
	 (nval (unsafe_get_field :nstpd_value nspr))
	 (oval (compile_obj nval gcx)) 
	 (res ())
	 )
    (cond 
     ( (is_a npred class_symbol)
       (let ( (namepred (make_string discr_verbatim_string (get_field :named_name npred))) )
	 (setq res 
	       (make_objcompute 
		nloc
		ctype_void
		##{MELT_STORE_PREDEF($NAMEPRED, (melt_ptr_t) ($OVAL))}#)))
       )
     ( (is_integerbox npred)
       (setq res 
	     (make_objcompute
	      nloc
	      ctype_void
	      ##{melt_store_predefined($NPRED, (melt_ptr_t) ($OVAL))}#))
       )
     (:else
      (debug "compilobj_nrep_store_predefined bad npred=" npred)
      (assert_msg "compilobj_nrep_store_predefined invalid npred" () npred)
      (return))
     )
    (debug "compilobj_nrep_store_predefined result res=" res)
    res
    ))
(install_method class_nrep_store_predefined compile_obj compilobj_nrep_store_predefined)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun compilobj_nrep_update_current_module_environment_reference (nucmeb gcx)
  (assert_msg "check nucmeb" (is_a nucmeb class_nrep_update_current_module_environment_reference) nucmeb)
  (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx)
  (debug "compilobj_nrep_update_current_module_environment_reference nucmeb=" nucmeb)
  (let ( (nloc (unsafe_get_field :nrep_loc nucmeb))
	 (ncomm (unsafe_get_field :ncumeb_comment nucmeb))
	 (nex (unsafe_get_field :nucmeb_expr nucmeb))
	 (pcml (unsafe_get_field :igncx_procurmodenvlist gcx))
	 (ocontenvloc (get_field :igncx_contenvloc gcx))
	 (csbuf (let ( (sb (make_strbuf discr_strbuf)) 
		       )
		  (add2sbuf_strconst sb "upd.cur.mod.env.cont")
		  (if (is_string ncomm)
		      (progn
			(add2sbuf_strconst sb " : ")
			(add2sbuf_string sb ncomm)))
		  sb
		  ))
	 (obodl (make_list discr_list))
	 (ocblo (instance class_objcommentedblock
			  :obi_loc nloc
			  :oblo_bodyl obodl
			  :ocomblo_comment 
			  (strbuf2string discr_string csbuf)))
	 (oex (compile_obj nex gcx))
	 )
    ;; get the igncx_procurmodenvlist from gcx
    ;; for each routine of class_procroutineobj  get its nrpro_const list and
    ;; for each CLASS_NREP_QUASIDATA_CURRENT_MODULE_ENVIRONMENT_REFERENCE there do ....
    (foreach_pair_component_in_list
     (pcml)
     (curpair curout)
     (debug "compilobj_nrep_update_current_module_environment_reference curout=" curout)
     (if (is_a curout class_procroutineobj)
	 (let (
	       (curproc (unsafe_get_field :obrout_proc curout))
	       (cnslis (get_field :nrclop_constlist curproc)) 
	       (datarout (unsafe_get_field :nrpro_datarout curproc))
	       (odatarout (compile_obj datarout gcx))
	       (boxcount (make_integerbox discr_integer 0))
	       (oroutlocvar (unsafe_get_field :oie_locvar odatarout))
	       )
	   (assert_msg "check odatarout" (is_a odatarout class_objinitroutine) odatarout)
	   (list_every 
	    cnslis
	    (lambda (curconst)
	      (let (
		    (:long curcount (get_int boxcount))
		    )
		(if (is_a curconst class_nrep_quasidata_current_module_environment_reference)
		    ;; set into oroutlocvar  the constant ranked curcount to oex
		    ;; and touch it
		    (let (
			  (oputrout (instance class_objputroutconst
					      :obi_loc nloc
					      :oprconst_rout oroutlocvar
					      :oprconst_off  (make_integerbox discr_integer curcount)
					      :oprconst_cval oex
					      ))
			  (otouchrout (instance class_objtouch
						:obi_loc nloc
						:otouch_val oroutlocvar
						:otouch_comment '"compobj.upd.mod.env.box"
						))
			  (ocopy (instance class_objcompute
					   :obi_loc nloc
					   :obdi_destlist (list ocontenvloc)
					   :obcpt_expr oex
					   :obcpt_type ctype_value
					   ))
			  )
		      (list_append obodl oputrout)
		      (list_append obodl otouchrout)
		      (list_append obodl ocopy)
		      )
		  )
		)
	      ))
	   (put_int boxcount (+i (get_int boxcount) 1))
	   )))
    (debug "compobj.upd.mod.env.box result ocblo=" ocblo)
    (return ocblo)
    ))
(install_method class_nrep_update_current_module_environment_reference compile_obj compilobj_nrep_update_current_module_environment_reference)





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilobj_nrep_check_running_module_environment_container (nchmeb gcx)
  (debug "compilobj_nrep_check_running_module_environment_container nchmeb=" nchmeb "\n gcx=" gcx)
  (assert_msg "check nucmeb" (is_a nchmeb class_nrep_check_running_module_environment_container) nchmeb)
  (assert_msg "check gcx" (is_a gcx class_extension_generation_context) gcx)
  (let (
	(nchcomm (get_field :nchrumod_comment nchmeb))
	(nloc (get_field :nrep_loc nchmeb))
	(ocontenvloc (get_field :igncx_contenvloc gcx))
	(pcml (get_field :igncx_procurmodenvlist gcx))
	(obodl (make_list discr_list))
	(csbuf (make_strbuf discr_strbuf))
	(locenv (get_free_objlocptr gcx '_curmodenv_)) ;stack location
					;for the
					;current
					;environment
	(ocblo (instance class_objcommentedblock
			 :obi_loc nloc
			 :oblo_bodyl obodl
			 :ocomblo_comment 
			 (progn
			   (add2out csbuf "check.run.mod.env:" nchcomm)
			   (strbuf2string discr_string csbuf))))
	(ochkcont (make_objlocatedexp 
		   nloc ctype_void
		   ##{ /*check running module environment reference*/
		   if (!melt_is_instance_of ((melt_ptr_t)$OCONTENVLOC,
					     (melt_ptr_t) MELT_PREDEF(CLASS_REFERENCE)))
		   melt_fatal_error ("MELT running extension with bad module environment reference @%p", (void*) $OCONTENVLOC) ;
		   }#))
	(ogetenv (make_objlocatedexp
		  nloc ctype_void
		  ##{ /*retrieve then check running module environment*/
		  $LOCENV = melt_reference_value ((melt_ptr_t)$OCONTENVLOC) ;
		  if (!melt_is_instance_of ((melt_ptr_t) $LOCENV,
					    (melt_ptr_t) MELT_PREDEF(CLASS_ENVIRONMENT)))
		  melt_fatal_error ("MELT running extension with bad environment @%p in its reference @%p",
				    (void*) $LOCENV, (void*) $OCONTENVLOC) ;
		  }#))
	)
    (debug "compilobj_nrep_check_running_module_environment_container ocblo=" ocblo "\n ocontenvloc=" ocontenvloc)
    (debug "compilobj_nrep_check_running_module_environment_container ochkcont=" ochkcont
	   "\n ogetenv=" ogetenv)
    (list_append obodl ochkcont)
    (list_append obodl ogetenv)
    (foreach_pair_component_in_list
     (pcml)
     (curpair curout)
     (debug "compilobj_nrep_update_current_module_environment_reference curout=" curout)
     (if (is_a curout class_procroutineobj)
	 (let (
	       (curproc (unsafe_get_field :obrout_proc curout))
	       (cnslis (get_field :nrclop_constlist curproc)) 
	       (datarout (unsafe_get_field :nrpro_datarout curproc))
	       (odatarout (compile_obj datarout gcx))
	       (boxcount (make_integerbox discr_integer 0))
	       (oroutlocvar (unsafe_get_field :oie_locvar odatarout))
	       )
	   (assert_msg "check odatarout" (is_a odatarout class_objinitroutine) odatarout)
	   (list_every 
	    cnslis
	    (lambda (curconst)
	      (let (
		    (:long curcount (get_int boxcount))
		    )
		(if (is_a curconst class_nrep_quasidata_current_module_environment_reference)
		    ;; set into oroutlocvar  the constant ranked curcount to oex
		    ;; and touch it
		    (let (
			  (oputrout (instance class_objputroutconst
					      :obi_loc nloc
					      :oprconst_rout oroutlocvar
					      :oprconst_off  (make_integerbox discr_integer curcount)
					      :oprconst_cval ocontenvloc
					      ))
			  (otouchrout (instance class_objtouch
						:obi_loc nloc
						:otouch_val oroutlocvar
						:otouch_comment '"updat.cur.running.mod.env"
						))
			  )
		      (list_append obodl oputrout)
		      (list_append obodl otouchrout)
		      )
		  )
		)
	      ))
	   (put_int boxcount (+i (get_int boxcount) 1))
	   ))) 
    (list_append obodl (instance class_objclear :obi_loc nloc
				 :oclr_vloc locenv))
    (dispose_objloc locenv gcx)
    (debug "compilobj_nrep_check_running_module_environment_container gives ocblo=" ocblo)
    (return ocblo)    
    ))
(install_method class_nrep_check_running_module_environment_container compile_obj compilobj_nrep_check_running_module_environment_container)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; selector to compile a matcher
;; receiver: some indirect instance of class_any_matcher
;; arguments:
;;; * the match compilation context
;;; * the generation context
;;;   
(defselector compile_matcher class_selector
)

(export_values compile_matcher)
(defclass class_matchcompilcontext 
  :super class_proped
  :fields (mcx_loc			;the location of the matcher
	   mcx_normtester		;the normtester
	   mcx_gotothen			;the goto then part
	   mcx_gotoelse 		;the goto else part
	   mcx_olist			;the objcode list to be filled
	   mcx_suffix			;the suffix for state expansion
	   mcx_statecounter		;boxed counter for state expansion
	   ))
(export_class class_matchcompilcontext)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; selector to compile a tester
;;;; receiver: the tester
;;;; first argument: the generator context gcx
;;;; second argument: the tester context tcx
;;;; return values: primary, the objcode or lists; secondary the destination objcode
(defselector compile_tester class_selector
  :doc #{Compile a tester $RECV for matching with generator context
  $GCX and tester context $TCX. Return the compiled tester and
  secondarily the destination.}#
  :formals (recv gcx tcx)
 )
(export_values compile_tester)
(defclass class_testercompilcontext
  :super class_proped
  :fields (tcx_nrmatch			;the nrep_matcher
	   tcx_freelist			;the list of free objloc
	   tcx_nextest			;the next test
))
(export_class class_testercompilcontext)


;;;; catch all
(defun compiltst_anytester (ntester gcx tcx)
  (assert_msg "check ntester" (is_a ntester class_normtester_any) ntester)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (debug ntester "compiltst_anytester ntester=" ntester)
  (outcstring_err "* compiltst unimplemented receiver class ")
  (let ( (discr (discrim ntester)) ) (outstr_err (unsafe_get_field :named_name discr)))
  (outnewline_err)
  (assert_msg "@@compile_tester should be implemented in normtesters-s subclasses" () ntester)
)
(install_method class_normtester_any compile_tester compiltst_anytester)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; compilation of old matches
(defun compilobj_nrep_match (nmat gcx)
  (assert_msg "check nmat" (is_a nmat class_nrep_match) nmat)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug  "compilobj_nrep_match nmat=" nmat)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc nmat))
	(nctyp (unsafe_get_field :nexpr_ctyp nmat))
	(ntests (unsafe_get_field :nmatch_tests nmat))
	(stuffmap (unsafe_get_field :nmatch_stuffmap nmat))
	(nmatched (get_field :nmatch_matched nmat))
	(matmap (unsafe_get_field :gncx_matchmap gcx))
	(matlabel (let ( (:long nbmat (mapobject_count matmap))
			 (labuf (make_strbuf discr_strbuf))
			 )
		    (add2sbuf_strconst labuf "mtch")
		    (add2sbuf_longdec labuf (+i nbmat 1))
		    (add2sbuf_strconst labuf "_")
		    (let ( (labstr (strbuf2string discr_verbatim_string labuf)) )
		      (mapobject_put matmap  nmat labstr)
		      (debug "compilobj_nrep_match matlabel labstr=" labstr)
		      labstr
		      )))
	(endlabel (let (
			(labuf (make_strbuf discr_strbuf))
			)
		    (add2sbuf_string labuf matlabel)
		    (add2sbuf_strconst labuf "_end")
		    (strbuf2string discr_verbatim_string labuf)))
	;; the list of suborders for putobjdest dispatch...
	;; should be the *last* of each sequence added...
	(subcomplist (make_list discr_list))
	(obodyl (make_list discr_list))
	(ombloc (instance class_objmultiblock
			  :obi_loc nloc
			  :oblo_bodyl obodyl
			  :omulblo_subcomp ()
			  ))
	(ofirstgoto (instance class_objgotoinstr
			      :obi_loc nloc
			      :obgoto_prefix matlabel
			      :obgoto_rank (make_integerbox discr_integer 0)
			      ))
	(oendlabel (instance class_objlabelinstr
			     :obi_loc nloc
			     :oblab_prefix endlabel
			     :oblab_rank ()))
	(tcx (instance class_testercompilcontext
		       :tcx_nrmatch nmat
		       :tcx_freelist (make_list discr_list)
		       :tcx_nextest ()	;updated below
		       ))
	(donetests (make_list discr_list))
	(omatched 
	 (progn 
	   (debug "compilobj_nrep_match nmatched=" nmatched)
	   (compile_obj nmatched gcx)))
	)
    (list_append obodyl ofirstgoto)
    (debug "compilobj_nrep_match ntests=" ntests " omatched=" omatched " oendlabel=" oendlabel)
    (foreach_in_multiple
     (ntests)
     (curotest :long testix)
     (debug "compilobj_nrep_match curotest=" curotest " testix=" testix)
     (assert_msg "check curotest" (is_a curotest class_normtester_any) curotest)
     (assert_msg "check curotest rank" (==i (get_int curotest) testix) testix)
     ;; do we have both then & else?
     (compile_warning 
      ;; we probably don't need to test the curnthen & curntest; they
      ;; probably are set...
      "probably useless tests - the then & else parts are here!" ())
     (if (is_a curotest class_normtester_anytester)
	 (let ( (curnthen (get_field :ntest_then curotest))
		(curnelse (get_field :ntest_else curotest))
		)
	   (cond 
	    ( (null curnthen)
	      (debug "compilobj_nrep_match  with null then curotest=" curotest)
	      (shortbacktrace_dbg "compilobj_nrep_match curotest has null then" 14)
	      )
	    ( (null curnelse)
	      (debug "compilobj_nrep_match with null else curotest=" curotest)
	      (shortbacktrace_dbg "compilobj_nrep_match curotest has null else" 14)
	      )
	   )))
     (let (
	   (labins (normtester_labelinstr curotest gcx))
	   (curnmatched (get_field :ntest_matched curotest))
	   )
       (debug "compilobj_nrep_match labins=" labins)
       (let ( (nextest (multiple_nth ntests (+i testix 1))) )
	 (put_fields tcx :tcx_nextest nextest)
	 (debug "compilobj_nrep_match nextest=" nextest " tcx=" tcx))
       (multicall
	(curcomp curobdest) 
	(compile_tester curotest gcx tcx)
	(debug "compilobj_nrep_match curcomp=" curcomp "curobdest=" curobdest)
	(assert_msg "check curcomp" curcomp)
	;; always add the labins and the curcomp or its element into obodyl
	(list_append obodyl labins)
	(cond 
	 ( (is_list curcomp)
	   (let ( (lastlicomp (pair_head (list_last curcomp))) )
	     (debug "compilobj_nrep_match lastlicomp=" lastlicomp)
	     (list_append2list obodyl curcomp)
	     ))
	 ( (is_multiple curcomp)
	   (let ( (lastupcomp (multiple_nth curcomp -1)) )
	     (debug "compilobj_nrep_match lastupcomp=" lastupcomp)
	     (foreach_in_multiple
	      (curcomp)
	      (subtest :long subix)
	      (list_append obodyl subtest))
	     ))
	 ( (is_object curcomp)
	   (debug "compilobj_nrep_match obj curcomp=" curcomp)
	   (list_append obodyl curcomp)
	   )
	 (:else
	  (assert_msg "unexpected curcomp" () curcomp)
	  ))
	;; add into subcomplist the curobdest if not null
	(if curobdest (list_append subcomplist curobdest))
	;; 
	(list_append donetests curotest)
	;; dispose some stuff
	(let ( (disposablist (make_list discr_list)) )
	  (debug "compilobj_nrep_match disposing curotest=" curotest)
	  (cond
	   ;; if the current test is a success, we can dispose all the
	   ;; stuff which has already been tested
	   ( (is_a curotest class_normtester_success)
	     (mapobject_every 
	      stuffmap
	      (lambda (stuff stutests)
		(if (!= stuff omatched)
		(let ( (remstuff stuff) )
		  (foreach_pair_component_in_list 
		   (stutests)
		   (testpair curtest)
		   (if (list_find donetests curtest)
		       (setq testpair ())
		     (setq remstuff ()))
		   )
		  (if remstuff 
		      (list_append disposablist remstuff))
		)))))
	   ;; if the curnmatched is the nmatched, we do nothing
	   ;; because we cannot dispose it
	   ( (== curnmatched nmatched)
	     (debug "compilobj_nrep_match curnmatched == nmatched=" nmatched)
	     )
	   ;; if the current test is not a success and the curnmatched
	   ;; is an object, we can dispose it if all its stuff has been
	   ;; tested
	   ( (is_object curnmatched)
	     (debug curnmatched
		    "compilobj_nrep_match disposing curnmatched=" curnmatched " omatched=" omatched)
	     (let ( (stutests (mapobject_get stuffmap curnmatched)) )
	       (let ( (remstuff curnmatched) )
		 (foreach_pair_component_in_list 
		  (stutests)
		  (testpair curtest)
		  (if (list_find donetests curtest)
		      (setq testpair ())
		    (setq remstuff ()))
		  )
		 (if remstuff 
		     (list_append disposablist remstuff))
		 )))) 
;;; dispose all the stuff in the disposablist 
	  (debug "compilobj_nrep_match disposablist=" disposablist)
	  (foreach_pair_component_in_list
	   (disposablist)
	   (dispair dispstuff)
	   (mapobject_remove stuffmap dispstuff)
	   (debug "compilobj_nrep_match dispstuff=" dispstuff)
	   (let ( (dispobj (compile_obj dispstuff gcx)) )
	     (debug "compilobj_nrep_match dispobj=" dispobj)
	     (assert_msg "check dispobj" (is_a dispobj class_objlocv) dispobj)
	     ;; but never dispose omatched itself
	     (if (!= dispobj omatched)
		 (dispose_objloc dispobj gcx)
	       (debug  "compilobj_nrep_match dont dispose omatched=" omatched))
	     ))))))
    (list_append obodyl oendlabel)
    (put_fields ombloc 
		:omulblo_subcomp (list_to_multiple subcomplist discr_multiple))
    (debug "compilobj_nrep_match return ombloc=" ombloc)
    (return ombloc ())
    ))
(install_method class_nrep_match compile_obj compilobj_nrep_match)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass class_alternate_match_nrep_data 
  :super class_root
  :fields (altmatchn_prev		;the previous
	   altmatchn_number		;unique number
	   altmatchn_nrep		;the current nrep_matchalt
	   altmatchn_flagmap		;mapping from match flags to objflags
	   altmatchn_datamap		;mapping from nrep matched data to objvalues
	   altmatchn_stepmap 		;mapping from match steps to their unique number
	   altmatchn_labprefix		;string prefix for labels
	   )
  )
(export_class class_alternate_match_nrep_data)


;;;; compilation of alternate matches
(defun compilobj_nrep_matchalt (nmat gcx)
  (debug "compilobj_nrep_matchalt nmat=" nmat "\n** gcx=" gcx 
	 "\n** class_objmatchflagblock=" class_objmatchflagblock "\n")
  (assert_msg "check nmat" (is_a nmat class_nrep_matchalt) nmat)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc nmat))
	(nctyp (unsafe_get_field :nexpr_ctyp nmat))
	(nmatched (unsafe_get_field :namatch_matched nmat))
	(nres (unsafe_get_field :namatch_result nmat))
	(nbody (unsafe_get_field :namatch_body nmat))
	(nflags (unsafe_get_field :namatch_flags nmat))
	(nmdatas (unsafe_get_field :namatch_mdatas nmat))
	(nstartlab (get_field :namatch_startlabel nmat))
	(obodyl (make_list discr_list))
	(oldaltmatch (get_field :gncx_altmatch gcx))
	(oldmatchnum (or (get_field :altmatchn_number oldaltmatch) '0))
	(matchnum (+ivi oldmatchnum 1))
	(oflagmap (make_mapobject discr_map_objects 
				  (+i 5 (*i 2 (multiple_length nflags)))))
	(odatamap (make_mapobject discr_map_objects
				  (+i 7 (*i 2 (multiple_length nmdatas)))))
	(ostepmap (make_mapobject discr_map_objects
				  (+i 13 (*i 3 (multiple_length nmdatas)))))
	(labprefix (string4out discr_verbatim_string "_meltmatchaltlab" matchnum "_"))
	(altmatch (instance class_alternate_match_nrep_data 
			    :altmatchn_prev oldaltmatch
			    :altmatchn_number matchnum
			    :altmatchn_nrep nmat
			    :altmatchn_flagmap oflagmap
			    :altmatchn_datamap odatamap
			    :altmatchn_stepmap ostepmap
			    :altmatchn_labprefix labprefix
			    )))
							      
    (debug "compilobj_nrep_matchalt nmatched=" nmatched "\n nres=" nres 
	   "\n nflags=" nflags "\n nctyp=" nctyp
	   "\n nbody=" nbody "\n oldaltmatch=" oldaltmatch
	   "\n new altmatch=" altmatch)
    (put_fields gcx :gncx_altmatch altmatch)
    (let (
	  (nsymbres (get_field :nocc_symb nres))
	  (obvares (get_free_objloctyped gcx nsymbres nctyp))
	  (ocleares (instance class_objclear
			      :obi_loc nloc
			      :oclr_vloc obvares))
	  )
      (list_append obodyl ocleares)
      ;;
      (debug "compilobj_nrep_matchalt nflags=" nflags)
      (let ( (oflags 
	      (multiple_map
	       nflags
	       (lambda (curnflag :long fix)
		 (debug "compilobj_nrep_matchalt/lambda curnflag=" curnflag " fix=" fix)
		 (let ( (curoflag (compile_obj curnflag gcx))
			)
		   (debug "compilobj_nrep_matchalt/lambda curoflag=" curoflag)
		   (return curoflag))))
	      )
	     (oblock (instance class_objmatchflagblock
			       :obi_loc nloc
			       :omchflgblo_flags oflags
			       :oblo_bodyl obodyl))
	     )
	(debug "compilobj_nrep_matchalt oflags=" oflags "\n oblock=" oblock
	       "\n nbody=" nbody "\n nstartlab=" nstartlab)
	;;
	;; fill the stepmap from class_nrep_match_label occurrences
	(foreach_in_multiple
	 (nbody)
	 (curncomp :long bodix)
	 (debug "compilobj_nrep_matchalt stepmap bodix#" bodix " curncomp=" curncomp)
	 (if (is_a curncomp class_nrep_match_label)
	     (let ( (labstep (get_field :nmlab_step curncomp))
		    (:long stepcount (mapobject_count ostepmap))
		    (stepnum (constant_box (+i stepcount 1)))
		   )
	       (debug "compilobj_nrep_matchalt labstep=" labstep "\n stepnum=" stepnum)
	       (assert_msg "check labstep" (or (is_a curncomp class_nrep_match_label_end) 
					       (is_a labstep class_match_step))
			   labstep)
	       (assert_msg "check unknown labstep" (null (mapobject_get ostepmap labstep)) labstep ostepmap)
	       (if labstep 
		   (mapobject_put ostepmap labstep stepnum))
	       ))
	 )
	(debug "compilobj_nrep_matchalt ostepmap=" ostepmap "\n.. nbody=" nbody)
	;;
	(foreach_in_multiple
	 (nbody)
	 (curncomp :long bodix)
	 (debug  "compilobj_nrep_matchalt curncomp=" curncomp " bodix=" bodix)
	 (let ( (curocomp (compile_obj curncomp gcx))
		)
	   (debug "compilobj_nrep_matchalt curocomp=" curocomp)
	   (assert_msg "check curocomp object" (is_object curocomp) curocomp)
	   (if (and (== curncomp nstartlab) 
		    (is_a curncomp class_nrep_match_label))
	       ;; we forcibly add a goto to the first label step, to
	       ;; avoid a label without goto warning from gcc
	       ;; compiling the generated code
	     (let ( (startstep (get_field :nmlab_step nstartlab))
		   (ostartjump
		     (instance class_objgotoinstr
			       :obgoto_prefix labprefix
			       :obgoto_rank (mapobject_get ostepmap startstep)))
		    )
	       (debug "compilobj_nrep_matchalt ostartjump=" ostartjump 
		      "\n startstep=" startstep
		      "\n ostepmap=" ostepmap)
	       (list_append obodyl ostartjump)
	     ))
	   (list_append obodyl curocomp)
	   ))
	;; we need to append the result at end of body
	(list_append obodyl obvares)
	;;
	(debug "compilobj_nrep_matchalt obodyl=" obodyl)
	(dispose_objloc obvares gcx)
	(put_fields gcx :gncx_altmatch oldaltmatch)
	;;
	(debug "compilobj_nrep_matchalt restored gcx=" gcx 
	       "\n* obodyl=" obodyl
	       "\n* result oblock=" oblock
	       "\n*****\n")
	(return oblock)
	))))
(install_method class_nrep_matchalt compile_obj compilobj_nrep_matchalt)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchlabel (nmlab gcx)
  (debug "compilobj_nrep_matchlabel nmlab=" nmlab " gcx=" gcx)
  (assert_msg "check nmlab" (is_a nmlab class_nrep_match_label) nmlab)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (get_field :nrep_loc nmlab))
	(nstep (get_field :nmlab_step nmlab))
	(altmatchdata (get_field :gncx_altmatch gcx))
	(labprefix (get_field :altmatchn_labprefix altmatchdata))
	(ostepmap (get_field :altmatchn_stepmap altmatchdata))
	(stepnum (mapobject_get ostepmap nstep))
	)
    (debug "compilobj_nrep_matchlabel nstep=" nstep
	   "\n stepnum=" stepnum "\n labprefix=" labprefix)
    (assert_msg "check altmatchdata" (is_a altmatchdata class_alternate_match_nrep_data) altmatchdata)
    (assert_msg "check nstep" (is_a nstep class_match_step) nstep)
    (assert_msg "check stepnum" (is_integerbox stepnum) stepnum)
    (assert_msg "check labprefix" (is_string labprefix) labprefix)
    (shortbacktrace_dbg "compilobj_nrep_matchlabel" 12)
    (let ( (olabinstr (instance class_objlabelinstr
				:obi_loc nloc
				:oblab_prefix labprefix
				:oblab_rank stepnum))
	   )
      (debug "compilobj_nrep_matchlabel result olabinstr=" olabinstr)
      (return olabinstr)
      )))

(install_method class_nrep_match_label compile_obj compilobj_nrep_matchlabel)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchlabelend (nmlab gcx)
  (debug "compilobj_nrep_matchlabelend nmlab=" nmlab " gcx=" gcx)
  (assert_msg "check nmlab" (is_a nmlab class_nrep_match_label_end) nmlab)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (get_field :nrep_loc nmlab))
	(altmatchdata (get_field :gncx_altmatch gcx))
	(labprefix (get_field :altmatchn_labprefix altmatchdata))
	)
    (debug "compilobj_nrep_matchlabel labprefix=" labprefix)
    (assert_msg "check labprefix" (is_string labprefix) labprefix)
    (shortbacktrace_dbg "compilobj_nrep_matchlabel" 12)
    (let ( (olabinstr (instance class_objlabelinstr
				:obi_loc nloc
				:oblab_prefix (string4out discr_verbatim_string labprefix "_end")
				)
		      )
	   )
      (debug "compilobj_nrep_matchlabel resultend olabinstr=" olabinstr)
      (return olabinstr)
      )))

(install_method class_nrep_match_label_end compile_obj compilobj_nrep_matchlabelend)


;;;;;;;;;;;;;;;;
;; the compilation of a match flag should give a 
(defun compilobj_nrep_matchflag (nmflag gcx)
  (debug "compilobj_nrep_matchflag nmflag=" nmflag "\n of discrim=" (discrim nmflag)
	 "\n** gcx=" gcx)
  (assert_msg "check nmflag" (is_a nmflag class_nrep_match_flag) nmflag)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let ( (nloc (unsafe_get_field :nrep_loc nmflag))
	 (nrfla (unsafe_get_field :nrpfla_flag nmflag))
	 (nrmatch (unsafe_get_field :nrpfla_nmatch nmflag))
	 (altmatchdata (get_field :gncx_altmatch gcx))
	 (oflagmap (get_field :altmatchn_flagmap altmatchdata))
	 )
    (debug "compilobj_nrep_matchflag nrfla=" nrfla " nrmatch=" nrmatch " oflagmap=" oflagmap)
    (assert_msg "check oflagmap" (is_mapobject oflagmap) oflagmap)
    (let ( (objmf (mapobject_get oflagmap nmflag))
	   )
      (if objmf
	  (progn
	    (debug "compilobj_nrep_matchflag found & returning objmf=" objmf)
	    (assert_msg "check ojbmf" (is_a objmf class_objflag) objmf)
	    (return objmf)))
      (setq objmf (instance class_objflag
			    :obv_type ctype_long
			    :obflag_matchflag nmflag
			    :obflag_name (get_field :mflag_string nrfla)
			    :obflag_rank (get_field :mflag_rank nrfla)))
      (mapobject_put oflagmap nmflag objmf)
      (debug "compilobj_nrep_matchflag new objmf=" objmf " in updated oflagmap=" oflagmap)
      (shortbacktrace_dbg "compilobj_nrep_matchflag" 15)
      (return objmf)
      )))

(install_method class_nrep_match_flag compile_obj compilobj_nrep_matchflag)

;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchdatainit (nmdat gcx)
  (debug "compilobj_nrep_matchdatainit nmdat=" nmdat 
	 "\n of discr=" (discrim nmdat) "\n gcx=" gcx)
  (assert_msg "check nmdat" (is_a nmdat class_nrep_match_data_initializer) nmdat)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (unsafe_get_field :nrep_loc nmdat))
	(ndata (get_field :nmdac_data nmdat))
	(ndatatype (get_field :nrmatd_ctype ndata))
	(ndatarank (get_field :nrmatd_rank ndata))
	(matdata (get_field :nrmatd_mdata ndata))
	(altmatch (get_field :gncx_altmatch gcx))
	(symb (or (get_field :mdata_symb matdata) (clone_symbol 'matchdata)))
	)
    (shortbacktrace_dbg "compilobj_nrep_matchdatainit" 10)
    (debug "compilobj_nrep_matchdatainit ndata=" ndata "\n* ndatatype=" ndatatype
	   "\n* ndatarank=" ndatarank 
	   "\n* matdata=" matdata "\n* altmatch=" altmatch
	   "\n* symb=" symb)
    (let (
	  (obvloc (get_free_objloctyped gcx symb ndatatype))
	  (aldatamap (get_field :altmatchn_datamap altmatch))
	  (obcl (instance class_objclear
			  :obi_loc nloc
			  :oclr_vloc obvloc))
	  )
      (debug "compilobj_nrep_matchdatainit obvloc=" obvloc
	     "\n* obcl=" obcl
	     "\n* aldatamap=" aldatamap)
      (assert_msg "unknown ndata in aldatamap" (null (mapobject_get aldatamap ndata)) ndata aldatamap)
      (mapobject_put aldatamap ndata obvloc)
      (debug "compilobj_nrep_matchdatainit updated aldatamap=" aldatamap 
	     "\n*return obcl=" obcl)
      (return obcl)
      )))

(install_method class_nrep_match_data_initializer compile_obj compilobj_nrep_matchdatainit)

;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchdataclear (nmc gcx)
  (debug "compilobj_nrep_matchdataclear nmc=" nmc "\n gcx=" gcx)
  (assert_msg "check nmc" (is_a nmc class_nrep_match_data_clear) nmc)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (get_field :nrep_loc nmc))
	(ndata (get_field :nmdac_data nmc))
	(odata (compile_obj ndata gcx))
	(oclear (instance class_objclear
			  :obi_loc nloc
			  :oclr_vloc odata))
	)
    (debug "compilobj_nrep_matchdataclear odata=" odata "\n result oclear=" oclear)
    (return oclear)
  ))
(install_method class_nrep_match_data_clear compile_obj compilobj_nrep_matchdataclear)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchdatafinal (nmdatf gcx)
  (debug "compilobj_nrep_matchdatafinal nmdatf=" nmdatf 
	 "\n of discr=" (discrim nmdatf) "\n gcx=" gcx)
  (assert_msg "check nmdatf" (is_a nmdatf class_nrep_match_data_finalizer) nmdatf)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (shortbacktrace_dbg "compilobj_nrep_matchdatafinal" 10)
  (let (
	(nloc (unsafe_get_field :nrep_loc nmdatf))
	(ndata (unsafe_get_field :nmdac_data nmdatf))
	(odata (compile_obj ndata gcx))
	;; no need to clear odata, it is already cleared before
	)
    (debug "compilobj_nrep_matchdatafinal ndata=" ndata "\n disposing odata=" odata 
	   "\n nmdatf=" nmdatf)
    (dispose_objloc odata gcx)
    (debug "compilobj_nrep_matchdatafinal end nmdatf=" nmdatf)
    (return)
    ))
(install_method class_nrep_match_data_finalizer compile_obj compilobj_nrep_matchdatafinal)


;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchedata (nmdat gcx)
  (debug "compilobj_nrep_matchedata nmdat=" nmdat 
	 "\n of discr=" (discrim nmdat) "\n gcx=" gcx)
  (assert_msg "check nmdat" (is_a nmdat class_nrep_matched_data) nmdat)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (unsafe_get_field :nrep_loc nmdat))
	(nctype (unsafe_get_field :nrmatd_ctype nmdat))
	(nrmdata (get_field :nrmatd_mdata nmdat))
	(nrmrank (get_field :nrmatd_rank nmdat))
	(altmatch (get_field :gncx_altmatch gcx))
	(aldatamap (get_field :altmatchn_datamap altmatch))
	(obmdat (mapobject_get aldatamap nmdat))
	)
    (shortbacktrace_dbg "compilobj_nrep_matcheddata" 10)
    (debug "compilobj_nrep_matchedata  altmatch=" altmatch "\n aldatamap=" aldatamap 
	   "\n obmdat=" obmdat "\n.. of discrim=" (discrim obmdat))
    (assert_msg "check obmdat" (is_a obmdat class_objvalue) obmdat)
    (return obmdat)
    ))
(install_method class_nrep_matched_data compile_obj compilobj_nrep_matchedata)




;;;;;;;;;;;;;;;;
(defun compilobj_nrep_matchjump (nmjump gcx)
  (debug "compilobj_nrep_matchjump nmjump=" nmjump 
	 "\n of discr=" (discrim nmjump) "\n gcx=" gcx)
  (assert_msg "check nmjump" (is_a nmjump class_nrep_match_jump) nmjump)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(nloc (unsafe_get_field :nrep_loc nmjump))
	(altmatchdata (get_field :gncx_altmatch gcx))
	(nmlab (get_field :nmjmp_label nmjump))
	(labprefix (get_field :altmatchn_labprefix altmatchdata))
	)
    (debug "compilobj_nrep_matchjump  altmatchdata=" altmatchdata
	   "\n *nmlab=" nmlab)
    (assert_msg "check altmatchdata" (is_a altmatchdata class_alternate_match_nrep_data) altmatchdata)
    (let ( (objgotomins
	    (cond ((is_a nmlab class_nrep_match_label_end)
		   (debug "compilobj_nrep_matchjump ending nmlab=" nmlab)
		   (instance class_objgotoinstr
			     :obi_loc nloc
			     :obgoto_prefix (string4out discr_verbatim_string 
							labprefix "_end")
			     ))
		  ((is_a nmlab class_nrep_match_label)
		   (let 
		       (
			(nstep (get_field :nmlab_step nmlab))
			(ostepmap (get_field :altmatchn_stepmap altmatchdata))
			(stepnum (mapobject_get ostepmap nstep))
			)
		     (debug "compilobj_nrep_matchjump nstep=" nstep "\n *stepnum=" stepnum)
		     
		     (instance class_objgotoinstr
			       :obi_loc nloc
			       :obgoto_prefix labprefix
			       :obgoto_rank stepnum)))
		  (:else
		   (assert_msg "unexpected nmlab" () nmlab))))
	   )
      (debug "compilobj_nrep_matchjump result objgotomins=" objgotomins)
      (return objgotomins)
      )))

(install_method class_nrep_match_jump compile_obj compilobj_nrep_matchjump)







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility function to return the label instr of a tester
(defun normtester_labelinstr (nt gcx)
  (debug "normtester_labelinstr start nt=" nt)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (if (is_not_a nt class_normtester_any)
      (progn
	(debug "normtester_labelinstr return nil")
	(return)))
  (let ( 
	(nloc (unsafe_get_field :nrep_loc nt))
	(:long ntestix (get_int nt))
	(normatch (unsafe_get_field :ntest_normatch nt))
	(matchmap (unsafe_get_field :gncx_matchmap gcx))
	)
    (assert_msg "check normatch" (is_a normatch class_nrep_match) normatch)
    (assert_msg "check valid normatch" 
		(== (multiple_nth (get_field :nmatch_tests normatch) 
				  ntestix) 
		    nt) normatch ntestix)
    (let (
	  (prefix (mapobject_get matchmap normatch))
	  (labins (instance class_objlabelinstr
			    :obi_loc nloc
			    :oblab_prefix prefix
			    :oblab_rank nt)) 
	  )
      (debug "normtester_labelinstr result labins=" labins)
      (assert_msg "check prefix" (is_string prefix) prefix)
      (return labins)
      )))


;; utility function to return the goto instr into a tester
(defun normtester_gotoinstr (nt gcx)
  (debug  "normtester_gotoinstr start nt=" nt)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (if (is_not_a nt class_normtester_any)
      (progn
	(debug "normtester_gotoinstr return nil")
	(return)))
  (let ( 
	(nloc (unsafe_get_field :nrep_loc nt))
	(:long ntestix (get_int nt))
	(normatch (unsafe_get_field :ntest_normatch nt))
	(matchmap (unsafe_get_field :gncx_matchmap gcx))
	)
    (debug "normtester_gotoinstr normatch=" normatch)
    (assert_msg "check normatch" (is_a normatch class_nrep_match) normatch)
    (assert_msg "check valid normatch" 
		(== (multiple_nth (get_field :nmatch_tests normatch) 
				  ntestix) 
		    nt) normatch ntestix)
    (let (
	  (prefix (mapobject_get matchmap normatch))
	  (goins (instance class_objgotoinstr
			    :obi_loc nloc
			    :obgoto_prefix prefix
			    :obgoto_rank nt)) 
	  )
      (debug "normtester_gotoinstr result goins=" goins)
      (assert_msg "check prefix" (is_string prefix) prefix)
      (return goins)
)))


;;; utility function to return the goto instr at end of matcher
(defun endmatch_gotoinstr (nma gcx nloc)
  (assert_msg "check nma" (is_a nma class_nrep_match) nma)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (debug "endmatch_gotoinstr nma=" nma)
  (shortbacktrace_dbg "endmatch_gotoinstr" 15)
  (let ( 
	(matchmap (unsafe_get_field :gncx_matchmap gcx))
	(prefix (mapobject_get matchmap nma))
	(labuf (make_strbuf discr_strbuf))
	)
    (add2sbuf_string labuf prefix)
    (add2sbuf_strconst labuf "_end /*endmatch*/")
    (let (
	  (goins (instance 
		  class_objgotoinstr
		  :obi_loc nloc
		  :obgoto_prefix (strbuf2string discr_verbatim_string labuf)
		  :obgoto_rank ()))
	  )
      (debug "endmatch_gotoinstr goins=" goins)
      (return goins)
)))

;; utility function to return the goto instr to a given tester
(defun testmatch_gotoinstr (ntest nma gcx nloc)
  (debug "testmatch_gotoinstr ntest=" ntest)
  (assert_msg "check ntest" (is_a ntest class_normtester_any) ntest)
  (assert_msg "check nma" (is_a nma class_nrep_match) nma)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (shortbacktrace_dbg "testmatch_gotoinstr" 15)
  (let ( 
	(matchmap (unsafe_get_field :gncx_matchmap gcx))
	(prefix (mapobject_get matchmap nma))
	(labuf (make_strbuf discr_strbuf))
	)
    (add2sbuf_string labuf prefix)
    (add2sbuf_longdec labuf (get_int ntest))
    (add2sbuf_strconst labuf " /*testmatch*/")
    (let (
	  (goins (instance 
		  class_objgotoinstr
		  :obi_loc nloc
		  :obgoto_prefix (strbuf2string discr_verbatim_string labuf)
		  :obgoto_rank ()))
	  )
      (debug "testmatch_gotoinstr goins=" goins)
      (return goins)
      )))

;;; utility function to get free objloc for the local occurrences of a tester
(defun normtester_free_objloc_list (nt gcx tcx)
  (debug "normtester_free_objloc_list nt=" nt)
  (assert_msg "check nt" (is_a nt class_normtester_any) nt)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloclist (unsafe_get_field :ntest_locclist nt))
	(locmap (unsafe_get_field :gncx_locmap gcx))
	)
    (debug "normtester_free_objloc_list nloclist=" nloclist)
    (shortbacktrace_dbg "normtester_free_objloc_list" 15)
    (let ( (freelist
	    (list_map 
	     nloclist 
	     (lambda (nloc) 
	       (assert_msg "check nloc" (is_a nloc class_nrep_locsymocc) nloc)
	       (let ( (oblo
		       (get_free_objloctyped gcx 
				     (get_field :nocc_symb nloc)
				     (get_field :nocc_ctyp nloc)
				     )) )
		 (mapobject_put locmap (get_field :nocc_bind nloc) oblo)
		 oblo
	       )))) 
	   )
      (list_append2list (get_field :tcx_freelist tcx) freelist)
      (debug "normtester_free_objloc_list result freelist=" freelist)
      (return freelist)
      )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; catch-all for unimplemented normtester
(defun compiltst_normtester_any (nta gcx tcx)
  (debug "compiltst_normtester_any nta=" nta 
	 "\n of discrim " (discrim nta)
	 "\n gcx=" gcx " tcx=" tcx)
  (error_strv (get_field :nrep_loc nta) 
	      "**UNIMPLEMENTED normal tester compilation "
	      (get_field :named_name (discrim nta)))
  (assert_msg "@$@UNIMPLEMENTED normal tester compilation" () nta gcx tcx)
)
(install_method class_normtester_any compile_tester compiltst_normtester_any)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compiltst_normtester_matcher (ntma gcx tcx)
  (debug "compiltst_normtester_matcher ntma=" ntma)
  (assert_msg "check ntma" (is_a ntma class_normtester_matcher) ntma)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntma))
	(nmatched (unsafe_get_field :ntest_matched ntma))
	(nthen (unsafe_get_field :ntest_then ntma))
	(nelse (unsafe_get_field :ntest_else ntma))
	(nmatcher (unsafe_get_field :ntmatch_matcher ntma))
	(nins (unsafe_get_field :ntmatch_inargs ntma))
	(nouts (unsafe_get_field :ntmatch_outlocs ntma))
	(normatch (unsafe_get_field :ntest_normatch ntma))
	(gotothen (normtester_gotoinstr nthen gcx))
	(gotoelse (normtester_gotoinstr nelse gcx))
	(olist (make_list discr_list))
	(matchmap (unsafe_get_field :gncx_matchmap gcx))
	(prefix (mapobject_get matchmap normatch))
	(freelist (normtester_free_objloc_list ntma gcx tcx))
	(nextest (get_field :tcx_nextest tcx))
	)
    (debug "compiltst_normtester_matcher matchmap=" matchmap " nextest=" nextest
	   " gotothen=" gotothen)
    (cond ( (null gotothen)
	    (shortbacktrace_dbg "compiltst_normtester_matcher null gotothen" 14)
	    (setq gotothen 
		  (if nextest 
		      (testmatch_gotoinstr nextest normatch gcx nloc)
		    (endmatch_gotoinstr normatch gcx nloc)))
	    (debug "compiltst_normtester_matcher fixed gotothen=" gotothen)
	    ))
    (debug "compiltst_normtester_matcher unfixed gotoelse=" gotoelse)
    (cond ( (null gotoelse)
	    (shortbacktrace_dbg "compiltst_normtester_matcher null gotoelse" 14)
	    (setq gotoelse 
		  (if nextest
		      (testmatch_gotoinstr nextest normatch gcx nloc)
		    (endmatch_gotoinstr normatch gcx nloc)))
	    (debug "compiltst_normtester_matcher fixed gotoelse=" gotoelse)
	    ))
    (debug "compiltst_normtester_matcher freelist=" freelist " prefix=" prefix)
    (assert_msg "check prefix" (is_string prefix) prefix)
    ;; clear the freelist
    (foreach_pair_component_in_list
     (freelist)
     (locpair obloc)
     (assert_msg "check obloc" (is_a obloc class_objlocv) obloc)
     (let ( (oclearob (instance class_objclear
				:obi_loc nloc
				:oclr_vloc obloc
				)) )
       (list_append olist oclearob)
       ))
    (debug "compiltst_normtester_matcher before nmatcher=" nmatcher)
    (let ( (matcx (instance class_matchcompilcontext
			    :mcx_loc nloc
			    :mcx_normtester ntma
			    :mcx_gotothen gotothen
			    :mcx_gotoelse gotoelse
			    :mcx_olist olist
			    :mcx_suffix prefix
			    :mcx_statecounter (make_integerbox discr_integer 0)
			    )) )
      (debug "compiltst_normtester_matcher matcx=" matcx)
      (compile_matcher nmatcher matcx gcx)
      (debug "compiltst_normtester_matcher return olist=" olist)
      (return olist ())
      )
    ))
(install_method class_normtester_matcher compile_tester compiltst_normtester_matcher)

;;;;;;;;;;;;;;;;
(defun compiltst_normtester_instance (ntmi gcx tcx)
  (debug "compiltst_normtester_instance ntmi=" ntmi)
  (assert_msg "check ntmi" (is_a ntmi class_normtester_instance) ntmi)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntmi))
	(nmatched (unsafe_get_field :ntest_matched ntmi))
	(nthen (unsafe_get_field :ntest_then ntmi))
	(nelse (unsafe_get_field :ntest_else ntmi))
	(normatch (unsafe_get_field :ntest_normatch ntmi))
	(nlocclist (unsafe_get_field :ntest_locclist ntmi))
	(olist (make_list discr_list))
	(:long ntestix (get_int ntmi))	
	(ntclass (unsafe_get_field :ntinst_class ntmi))
	(ntflds (unsafe_get_field :ntinst_fieldlocs ntmi))
	(gotothen (or (normtester_gotoinstr nthen gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	(gotoelse (or (normtester_gotoinstr nelse gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	(oclass (compile_obj ntclass gcx))
	(omatched (compile_obj nmatched gcx))
	(freelist (normtester_free_objloc_list ntmi gcx tcx))
	(othenlist (make_list discr_list))
	(oelselist (make_list discr_list))
	(othenblock (instance class_objplainblock
			      :obi_loc nloc
			      :oblo_bodyl othenlist
			      ))
	(oelseblock (instance class_objplainblock
			      :obi_loc nloc
			      :oblo_bodyl oelselist))
	(otest 
	 (make_objlocatedexp 
	  nloc ctype_long
	  ##{/*normtesterinst*/ (melt_is_instance_of((melt_ptr_t)($OMATCHED),
						     (melt_ptr_t)($OCLASS)))}#))	     
	(ocond (instance class_objcond
			 :obi_loc nloc
			 :obcond_test otest
			 :obcond_then othenblock
			 :obcond_else oelseblock))
	)
    (debug "compiltst_normtester_instance otest=" otest
	   " gotothen=" gotothen " gotoelse=" gotoelse
	   " ocond=" ocond)
    (assert_msg "check oclass" (is_object oclass) oclass)
    ;; clear the freelist
    (foreach_pair_component_in_list
     (freelist)
     (locpair obloc)
     (debug "compiltst_normtester_instance obloc=" obloc)
     (assert_msg "check obloc" (is_a obloc class_objlocv) obloc)
     (let ( (oclearob (instance class_objclear
				 :obi_loc nloc
				 :oclr_vloc obloc
				 )) )
       (list_append olist oclearob)
     ))
    ;; add the cond
    (list_append olist ocond)
    ;; we have to add into the othenlist the fetch of each field and
    ;; the gotothen
    (debug "compiltst_normtester_instance ntflds=" ntflds " nlocclist=" nlocclist)
    (foreach_in_multiple
     (ntflds)
     (fldoc :long fldix)
     (if fldoc
	 (progn
	   (debug "compiltst_normtester_instance fldoc=" fldoc " fldix=" fldix)
	   (assert_msg "check fldoc" (is_a fldoc class_nrep_locsymocc) fldoc)
	   (let ( (flovar (compile_obj fldoc gcx))
		  (flbind (unsafe_get_field :nocc_bind fldoc))
		  (fldget (unsafe_get_field :letbind_expr flbind))
		  (ofget (compile_obj fldget gcx))
		  )
	     (assert_msg "check flbind" (is_a flbind class_normal_let_binding) flbind)
	     (assert_msg "check fldget" (is_a fldget class_nrep_unsafe_get_field) fldget)
	     (put_objdest ofget flovar)
	     (debug "compiltst_normtester_instance ofget=" ofget)
	     (assert_msg "check ofget" (is_object ofget) ofget)
	     (list_append othenlist ofget)
     ))))
    ;; also add the gotothen
    (assert_msg "check gotothen" (is_object gotothen) gotothen)
    (list_append othenlist gotothen)
    ;;
    ;; add into the oelselist the gotoelse
    (assert_msg "check gotoelse" (is_object gotoelse) gotoelse)
    (list_append oelselist gotoelse)
    (debug  "compiltst_normtester_instance final olist=" olist)
    (return olist ())
    )
  )
(install_method class_normtester_instance compile_tester compiltst_normtester_instance)




;;;;;;;;;;;;;;;;
(defun compiltst_normtester_tuple (ntup gcx tcx)
  (debug "compiltst_normtester_tuple ntup=" ntup " of discrim=" (discrim ntup))
  (assert_msg "check ntup" (is_a ntup class_normtester_tuple) ntup)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( (nloc (unsafe_get_field :nrep_loc ntup))
	 (nmatched (unsafe_get_field :ntest_matched ntup))
	 (nthen (unsafe_get_field :ntest_then ntup))
	 (nelse (unsafe_get_field :ntest_else ntup))
	 (normatch (unsafe_get_field :ntest_normatch ntup))
	 (nlocclist (unsafe_get_field :ntest_locclist ntup))
	 (ntupcomp (unsafe_get_field :nttuple_components ntup))
	 (:long nbcomp (multiple_length ntupcomp))
	 (olist (make_list discr_list))
	 (:long ntestix (get_int ntup))	
	 (gotothen (or (normtester_gotoinstr nthen gcx)
		       (endmatch_gotoinstr normatch gcx nloc)))
	 (gotoelse (or (normtester_gotoinstr nelse gcx)
		       (endmatch_gotoinstr normatch gcx nloc)))
	 (omatched (compile_obj nmatched gcx))
	 (freelist (normtester_free_objloc_list ntup gcx tcx))
	 (othenlist (make_list discr_list))
	 (oelselist (make_list discr_list))
	 (othenblock (instance class_objplainblock
			       :obi_loc nloc
			       :oblo_bodyl othenlist
			       ))
	 (oelseblock (instance class_objplainblock
			       :obi_loc nloc
			       :oblo_bodyl oelselist))
	 (otest 
	  (make_objlocatedexp
	   nloc ctype_long
	   ##{/*normtestertuple*/ (melt_magic_discr((melt_ptr_t)($OMATCHED)) == MELTOBMAG_MULTIPLE
		&& ((meltmultiple_ptr_t)($OMATCHED))->nbval == $NBCOMP)}#)				   )
	 (ocond (instance class_objcond
			  :obi_loc nloc
			  :obcond_test otest
			  :obcond_then othenblock
			  :obcond_else oelseblock))
	 )
    (debug "compiltst_normtester_tuple omatched=" omatched " freelist=" freelist 
	   "\n otest=" otest
	   "\n ocond=" ocond)
    ;; clear the freelist
    (foreach_pair_component_in_list
     (freelist)
     (locpair obloc)
     (debug "compiltst_normtester_tuple obloc=" obloc)
     (assert_msg "check obloc" (is_a obloc class_objlocv) obloc)
     (let ( (oclearob (instance class_objclear
				:obi_loc nloc
				:oclr_vloc obloc
				)) )
       (list_append olist oclearob)
       ))
    ;; add the cond
    (list_append olist ocond)
    ;; we have to add into the othenlist the fetch of each component and
    ;; the gotothen
    (debug "compiltst_normtester_tuple ntupcomp=" ntupcomp)
    (foreach_in_multiple
     (ntupcomp)
     (curntup :long tupix)
     (debug "compiltst_normtester_tuple curntup=" curntup " tupix=" tupix)
     (if curntup
	 (let ( (curovar (compile_obj curntup gcx))
		(cnbind (get_field :nocc_bind curntup))
		(curbexp (get_field :letbind_expr cnbind))
		(curoexp (compile_obj curbexp gcx))
	     )
	   (debug "compiltst_normtester_tuple curovar=" curovar 
		  "  cnbind=" cnbind "  curbexp=" curbexp "  curoexp=" curoexp
		  " tupix=" tupix)
	   (assert_msg "check curovar" (is_a curovar class_objlocv) curovar)
	   (assert_msg "check cnbind" (is_a cnbind class_normal_let_binding) cnbind)
	   (assert_msg "check curbexp" (is_a curbexp class_nrep_unsafe_nth_component) curbexp)
	   (assert_msg "check nthrnk" (==i (get_int (get_field :nunth_index curbexp)) tupix) curbexp)
	   (put_objdest curoexp curovar)
	   (debug "compiltst_normtester_tuple updated curoexp=" curoexp)
	   (list_append othenlist curoexp)
	   ))
     );; end foreach ntupcomp
    ;; also add the gotothen
    (assert_msg "check gotothen" (is_object gotothen) gotothen)
    (list_append othenlist gotothen)
    ;;
    ;; add into the oelselist the gotoelse
    (assert_msg "check gotoelse" (is_object gotoelse) gotoelse)
    (list_append oelselist gotoelse)
    (debug "compiltst_normtester_tuple final olist=" olist)
    (return olist ())
    ))
(install_method class_normtester_tuple compile_tester compiltst_normtester_tuple)




;;;;;;;;;;;;;;;;
(defun compiltst_normtester_same (ntsa gcx tcx)
  (debug "compiltst_normtester_same ntsa=" ntsa)
  (assert_msg "check ntsa" (is_a ntsa class_normtester_same) ntsa)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntsa))
	(nmatched (unsafe_get_field :ntest_matched ntsa))
	(nthen (unsafe_get_field :ntest_then ntsa))
	(nelse (unsafe_get_field :ntest_else ntsa))
	(normatch (unsafe_get_field :ntest_normatch ntsa))
	(nidentical (unsafe_get_field :ntsame_identical ntsa))
	(:long ntestix (get_int ntsa))	
	(omatched (compile_obj nmatched gcx))
	(oidentical (compile_obj nidentical gcx))
	(gotothen (or (normtester_gotoinstr nthen gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	(gotoelse (or (normtester_gotoinstr nelse gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	(freelist (normtester_free_objloc_list ntsa gcx tcx))
	(othenlist (make_list discr_list))
	(oelselist (make_list discr_list))
	(othenblock (instance class_objplainblock
			      :obi_loc nloc
			      :oblo_bodyl othenlist
			      ))
	(oelseblock (instance class_objplainblock
			      :obi_loc nloc
			      :oblo_bodyl oelselist))
	(otest
	 (make_objlocatedexp 
	  nloc ctype_long
	  ##{/*testersame*/ ($OMATCHED == $OIDENTICAL)}#))
	(ocond (instance class_objcond
			 :obi_loc nloc
			 :obcond_test otest
			 :obcond_then othenblock
			 :obcond_else oelseblock))
	(olist (make_list discr_list))
	)
    (debug "compiltst_normtester_same ocond=" ocond)
    ;; clear the freelist
    (foreach_pair_component_in_list
     (freelist)
     (locpair obloc)
     (assert_msg "check obloc" (is_a obloc class_objlocv) obloc)
     (let ( (oclearob (instance class_objclear
				 :obi_loc nloc
				 :oclr_vloc obloc
				 )) )
       (list_append olist oclearob)
     ))
    ;; add the cond
    (list_append olist ocond)
    ;; also add the gotothen
    (assert_msg "check gotothen" (is_object gotothen) gotothen)
    (list_append othenlist gotothen)
    ;; add into the oelselist the gotoelse
    (assert_msg "check gotoelse" (is_object gotoelse) gotoelse)
    (list_append oelselist gotoelse)
    (debug "compiltst_normtester_same return olist=" olist)
    (return olist ())
    )
)
(install_method class_normtester_same compile_tester compiltst_normtester_same)


;;;;;;;;;;;;;;;;
(defun compiltst_normtester_success (ntsu gcx tcx)
  (debug "compiltst_normtester_success ntsu=" ntsu " tcx=" tcx)
  (assert_msg "check ntsu" (is_a ntsu class_normtester_success) ntsu)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntsu))
	(nmatched (unsafe_get_field :ntest_matched ntsu))
	(nthen (unsafe_get_field :ntest_then ntsu))
	(nelse (unsafe_get_field :ntest_else ntsu))
	(nloclis (unsafe_get_field :ntest_locclist ntsu))
	(normatch (unsafe_get_field :ntest_normatch ntsu))
	(nsucdo (unsafe_get_field :ntsuccess_do ntsu))
	(:long ntestix (get_int ntsu))	
	(gotoend (endmatch_gotoinstr normatch gcx nloc))
	)
    (assert_msg "check nil nloclis" (null nloclis) nloclis)
    (assert_msg "check nil nthen" (null nthen) nthen)
    (assert_msg "check nil nelse" (null nelse) nelse)
    (let ( (osucc (compile_obj nsucdo gcx)) 
	   )
      ;; maybe we have to free all the location allocated for this test
      (if (is_list osucc)
	  (progn
	    (list_append osucc gotoend)
	    (return osucc (list_last osucc)))
	(return (list osucc gotoend) osucc))
      )))
(install_method class_normtester_success compile_tester compiltst_normtester_success)

;;;;;;;;;;;;;;;;
(defun compiltst_normtester_orclear (ntoc gcx tcx)
  (debug "compiltst_normtester_orclear ntoc=" ntoc)
  (assert_msg "check ntoc" (is_a ntoc class_normtester_or_clear) ntoc)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntoc))
	(nmatched (unsafe_get_field :ntest_matched ntoc))
	(normatch (unsafe_get_field :ntest_normatch ntoc))
	(nthen (unsafe_get_field :ntest_then ntoc))
	(nelse (unsafe_get_field :ntest_else ntoc))
	(nclear (unsafe_get_field :ntorclear_locsym ntoc))
	(locmap (unsafe_get_field :gncx_locmap gcx))
	(olist (make_list discr_list))
	(gotothen (or (normtester_gotoinstr nthen gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
;;;	(gotoelse (or (normtester_gotoinstr nelse gcx)
;;;		      (endmatch_gotoinstr normatch gcx nloc)))
	)
    (debug "compiltst_normtester_orclear nclear=" nclear
	   " nthen=" nthen " nelse=" nelse)
    (assert_msg "check nclear" (is_multiple nclear) nclear)
    (foreach_in_multiple
     (nclear)
     (curlocs :long cix)
     (debug "compiltst_normtester_orclear curlocs=" curlocs " cix=" cix)
     (shortbacktrace_dbg "compiltst_normtester_orclear curlocs" 14)
     (let ( 
	   ;; TODO: perhaps we should not allocate a new obva but just
	   ;; compile the curlocs
	   (ocurl (let ( (oc (compile_obj curlocs gcx)) 
			 )
		    (debug "compiltst_normtester_orclear ocurl=" oc)
		    oc))
	   (oclrloc (instance class_objclear
			      :obi_loc nloc
			      :oclr_vloc ocurl
			      ))
	   )
       (debug "compiltst_normtester_orclear oclrloc=" oclrloc)
       (list_append olist oclrloc)
       )
     )
    (list_append olist gotothen)
    (debug "compiltst_normtester_orclear final olist=" olist)
    (return olist ())
    ))
(install_method class_normtester_or_clear compile_tester compiltst_normtester_orclear)
;;;;;;;;;;;;;;;;

(defun compiltst_normtester_ortransmit (ntot gcx tcx)
  (debug "compiltst_normtester_ortransmit ntot=" ntot)
  (assert_msg "check ntot" (is_a ntot class_normtester_or_transmit) ntot)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let ( 
	(nloc (unsafe_get_field :nrep_loc ntot))
	(nmatched (unsafe_get_field :ntest_matched ntot))
	(normatch (unsafe_get_field :ntest_normatch ntot))
	(ntupdst (unsafe_get_field :ntortransmit_dst ntot))
	(ntupsrc (unsafe_get_field :ntortransmit_src ntot))
	(nthen (unsafe_get_field :ntest_then ntot))
	(nelse (unsafe_get_field :ntest_else ntot))
	(olist (make_list discr_list))
	(gotothen (or (normtester_gotoinstr nthen gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	)
    (assert_msg "check null nelse" (null nelse) nelse)
    (assert_msg "check same size ntupsc ntupdst" 
		(==i (multiple_length ntupdst) (multiple_length ntupsrc)) ntupsrc ntupdst)
    (foreach_in_multiple
     (ntupdst)
     (ncurdst :long nix)
     (let ( (ncursrc (multiple_nth ntupsrc nix)) 
	    )
       (debug "compiltst_normtester_ortransmit ncursrc=" ncursrc " ncurdst=" ncurdst " nix=" nix)
       (let ( 
	     (osrc (compile_obj ncursrc gcx))
	     (dstype (get_field :nocc_ctyp ncurdst))
	     (odst (compile_obj ncurdst gcx))
	     (dstlist (make_list discr_list))
	     (ocomp (instance class_objcompute
		     :obi_loc nloc
		     :obdi_destlist dstlist
		     :obcpt_type dstype
		     :obcpt_expr osrc))
	     )
	 (list_append dstlist odst)
	 (debug "compiltst_normtester_ortransmit osrc=" osrc " odst=" odst " ocomp=" ocomp)
	 (list_append olist ocomp)
       )))
    (list_append olist gotothen)
    (debug "compiltst_normtester_ortransmit final olist=" olist)
    (return olist ())
    ))
(install_method class_normtester_or_transmit compile_tester compiltst_normtester_ortransmit)

;;;;;;;;;;;;;;;;
;; to compile a disjunction, just goto the then case, because the
;; disjunction is only here to redistribute the then case inside the
;; disjuncts.
(defun compiltst_normtester_disjunction (ntdj gcx tcx)
  (debug "compiltst_normtester_disjunction ntdj=" ntdj)
  (assert_msg "check ntdj" (is_a ntdj class_normtester_disjunction) ntdj)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx)
  (let (
	(locmap (unsafe_get_field :gncx_locmap gcx))
	(nloc (unsafe_get_field :nrep_loc ntdj))
	(nthen (unsafe_get_field :ntest_then ntdj))
	(normatch (unsafe_get_field :ntest_normatch ntdj))
	(ndisjlocsy (unsafe_get_field :ntdisj_freshorvar ntdj))
	(gotothen (or (normtester_gotoinstr nthen gcx)
		      (endmatch_gotoinstr normatch gcx nloc)))
	;; not sure that freelist is needed!
	(freelist (normtester_free_objloc_list ntdj gcx tcx))
	)
    (debug "compiltst_normtester_disjunction ndisjlocsy=" ndisjlocsy " gotothen=" gotothen " freelist=" freelist)
    (compile_warning "do we need the freelist in compiltst_normtester_disjunction?")
    (foreach_in_multiple
     (ndisjlocsy)
     (curdisjloc :long lix)
     (debug  "compiltst_normtester_disjunction curdisjloc=" curdisjloc " lix=" lix)
     (assert_msg "check curdisjloc" (is_a curdisjloc class_nrep_locsymocc) curdisjloc)
     (let ( (dbind (unsafe_get_field :nocc_bind curdisjloc))
	    (dsymb (unsafe_get_field :nocc_symb curdisjloc))
	    (dctyp (unsafe_get_field :nocc_ctyp curdisjloc))
	    (dobva (get_free_objloctyped gcx
					 dsymb
					 dctyp))
	   )
       (debug "compiltst_normtester_disjunction dobva=" dobva)
       (mapobject_put locmap dbind dobva)
       )
     )
    (return gotothen ())
    )
  )
(install_method class_normtester_disjunction compile_tester compiltst_normtester_disjunction)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilmatcher_cmatcher (cmat mcx gcx)
  (debug "compilmatcher_cmatcher cmat=" cmat " mcx=" mcx)
  (assert_msg "check cmat" (is_a cmat class_cmatcher) cmat)
  (assert_msg "check mcx" (is_a mcx class_matchcompilcontext) mcx)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(cmins (unsafe_get_field :amatch_in cmat))
	(cmbind (unsafe_get_field :amatch_matchbind cmat))
	(cmouts (unsafe_get_field :amatch_out cmat))
	(cmstate (unsafe_get_field :cmatch_state cmat))
	(cmexptest (unsafe_get_field :cmatch_exptest cmat))
	(cmexpfill (unsafe_get_field :cmatch_expfill cmat))
	;; the normtester
	(normtester (unsafe_get_field :mcx_normtester mcx))
	;; the subsitution map
	(substmap (make_mapobject discr_map_objects 
				  (+i 5
				      (*i 2 (+i (multiple_length cmins)
						(multiple_length cmouts))))))
	(:long mcxcount
	       (let ( (boxcnt (get_field :mcx_statecounter mcx))
		      (:long cnt (+i 1 (get_int boxcnt)) ) )
		 (put_int boxcnt cnt)
		 cnt))
	;; generate a unique state string
	(uniqstate (let ( (sbuf (make_strbuf discr_strbuf)) )
		     (add2sbuf_cident sbuf (get_field :named_name cmstate))
		     (add2sbuf_strconst sbuf "_")
		     (add2sbuf_string sbuf (get_field :mcx_suffix mcx))
		     (add2sbuf_strconst sbuf "_")
		     (add2sbuf_longdec sbuf mcxcount)
		     (strbuf2string discr_verbatim_string sbuf)))
	;; fetch the olist to add instructions into
	(olist (get_field :mcx_olist mcx))
	)
    ;; map the state to the unique string 
    (mapobject_put substmap cmstate uniqstate)
    ;; map the matched thing 
    (let ( (nmatched (get_field :ntest_matched normtester)) )
      (debug "compilmatcher_cmatcher nmatched=" nmatched)
      (let ( (obmatched (compile_obj nmatched gcx)) )
	(debug "compilmatcher_cmatcher obmatched=" obmatched)
	(mapobject_put substmap
		       (get_field :binder cmbind)
		       obmatched
		       )))
    ;;
    (debug "compilmatcher_cmatcher normtester=" normtester)
    ;; map each input arguments
    (multiple_every_both 
     (get_field :ntmatch_inargs normtester)
     cmins
     (lambda (curin formin :long ix)
       (debug "compilmatcher_cmatcher curin=" curin " formin=" formin " ix=" ix)
       (assert_msg "check formin" (is_a formin class_formal_binding) formin)
       (let ( (oin (compile_obj curin gcx)) )
	 (debug "compilmatcher_cmatcher oin=" oin)
	 (mapobject_put substmap
			(get_field :binder formin)
			oin)
	 )))
    ;; map each output arguments
    (multiple_every_both
     (get_field :ntmatch_outlocs normtester)
     cmouts
     (lambda (curout formout :long ix)
       (debug "compilmatcher_cmatcher curout=" curout " formout=" formout " ix=" ix)
       (assert_msg "check formout" (is_a formout class_formal_binding) formout)
       (let ( (oout (compile_obj curout gcx)) )
	 (debug "compilmatcher_cmatcher oout=" oout " ix=" ix)
	 (mapobject_put substmap
			(get_field :binder formout)
			oout))
       ))
    (debug "compilmatcher_cmatcher substmap=" substmap)
    ;; expand
    (let (
	  (mcxloc (get_field :mcx_loc mcx))
	  (expander 
	   (lambda (tup)
	     (multiple_map
	      tup
	      (lambda (c)
		(cond 
		 ( (is_a c class_symbol)
		   (let ( (r (mapobject_get substmap c)) )
		     (if (null r)
			 (error_at mcx_loc
				   "invalid symbol $1 to expand for cmatcher" c))
		     r))
		 ( (is_object c)
		   (error_at mcxloc
			     "invalid object of $1 to expand for cmatcher"
			     (get_field :named_name (discrim c))))
		 ( (is_integerbox c)
		   (constant_box (get_int c)))
		 ( (is_string c)
		   (make_string discr_verbatim_string c))
		 (:else
		  (error_at mcxloc
			    "invalid stuff $1 of $2 to expand for cmatcher"
			    c
			    (get_field :named_name (discrim c))
			    )))))))
	  (exptest (expander cmexptest))
	  (expfill (expander cmexpfill))
	  (mloc (get_field :mcx_loc mcx))
	  (testchunk (instance class_objlocatedexpv
			       :obv_type ctype_long
			       :obx_cont exptest
			       :obcx_loc mloc))
	  (fillchunk (instance class_objlocatedexpv
			       :obv_type ctype_void
			       :obx_cont expfill
			       :obcx_loc mloc))
	  )
      (debug  "compilmatcher_cmatcher exptest=" exptest " expfill=" expfill
	      " testchunk=" testchunk " fillchunk=" fillchunk)
      (assert_msg "compilmatcher_cmatcher check exptest" exptest)
      (let ( 
	    (othenlist (make_list discr_list))
	    (othenbody (instance class_objplainblock
				 :obi_loc mloc
				 :oblo_bodyl othenlist
				 ))
	    (oelselist (make_list discr_list))
	    (oelsebody (instance class_objplainblock
				 :obi_loc mloc
				 :oblo_bodyl oelselist
				 ))
	    (ocond (instance class_objcond
			     :obi_loc mloc
			     :obcond_test testchunk
			     :obcond_then othenbody
			     :obcond_else oelsebody
			     ))
	    )
	(debug "compilmatcher_cmatcher ocond=" ocond)
	(list_append olist ocond)
	(foreach_in_multiple
	 (cmouts)
	 (curout :long outix)
	 (debug "compilmatcher_cmatcher curout=" curout " outix=" outix)
	 (assert_msg "check curout" (is_a curout class_formal_binding) curout)
	 (let ( (locout
		 (mapobject_get substmap 
				(unsafe_get_field :binder curout)))
		(oclearout (instance class_objclear
				     :obi_loc mloc
				     :oclr_vloc locout)) )
	   (debug "compilmatcher_cmatcher oclearout=" oclearout)
	   (assert_msg "check locout" (is_object locout) locout)
	   (list_append othenlist oclearout)
	   )
	 )
	(list_append othenlist fillchunk)
	(list_append othenlist (get_field :mcx_gotothen mcx))
	(list_append oelselist (get_field :mcx_gotoelse mcx))
	(debug "compilmatcher_cmatcher final ocond=" ocond)
	)
      )))
(install_method class_cmatcher compile_matcher compilmatcher_cmatcher)






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compilmatcher_funmatcher (fmat mcx gcx)
  (debug "compilmatcher_funmatcher fmat=" fmat " mcx=" mcx)
  (assert_msg "check fmat" (is_a fmat class_funmatcher) fmat)
  (assert_msg "check mcx" (is_a mcx class_matchcompilcontext) mcx)
  (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx)
  (let (
	(fmins (unsafe_get_field :amatch_in fmat))
	(fmbind (unsafe_get_field :amatch_matchbind fmat))
	(fmouts (unsafe_get_field :amatch_out fmat))
	(ntma (get_field :mcx_normtester mcx))
	;; fetch the olist to add instructions into
	(olist (get_field :mcx_olist mcx)) 
	(mloc (get_field :mcx_loc mcx))
	)
    (debug "compilmatcher_funmatcher ntma=" ntma)
    (assert_msg "check ntma" (is_a ntma class_normtester_matcher) ntma)
    (let ( (matndata (get_field :ntmatch_matndata ntma)) 
	   (omatdata (compile_obj matndata gcx))
	   (nmatched (get_field :ntest_matched ntma))
	   (omatched (compile_obj nmatched gcx))
	   (nins (get_field :ntmatch_inargs ntma))
	   (nouts (get_field :ntmatch_outlocs ntma))
	   (oins (multiple_map 
		  nins 
		  (lambda (thein)
		    (compile_obj thein gcx)
		    )))
	   (oouts (multiple_map 
		  nouts 
		  (lambda (theout)
		    (compile_obj theout gcx)
		    )))
	   (otestres (get_free_objlocptr gcx fmat))
	   (otestclos (get_free_objlocptr gcx '_closfunmatch))
	   )
      (debug "compilmatcher_funmatcher matndata=" matndata " omatdata=" omatdata
	     " fmins=" fmins " fmbind=" fmbind " fmouts=" fmouts
	     " nins=" nins " nouts=" nouts
	     " nmatched=" nmatched " omatched=" omatched
	     " oins=" oins " oouts=" oouts " ntma=" ntma 
	     " otestres=" otestres " otestclos=" otestclos)
      ;; should generate a multiapplication etc...
      (let (
	    (oargs (make_multiple discr_multiple (+i 2 (multiple_length oins))))
	    (ogetclos (instance class_objgetslot
				:obi_loc mloc
				:obdi_destlist (list otestclos)
				:ogetsl_obj omatdata
				:ogetsl_field fmatch_matchf
				))
	    (omapp (instance class_objmultiapply
			      :obi_loc mloc
			      :obdi_destlist (list otestres)
			      :obapp_clos otestclos
			      :obapp_args oargs
			      :obmultapp_xres oouts
			      ))
	    (othenlist (make_list discr_list))
	    (othenbody (instance class_objplainblock
				 :obi_loc mloc
				 :oblo_bodyl othenlist
				 ))
	    (oelselist (make_list discr_list))
	    (oelsebody (instance class_objplainblock
				 :obi_loc mloc
				 :oblo_bodyl oelselist
				 ))
	    (ocond (instance class_objcond
			     :obi_loc mloc
			     :obcond_test otestres
			     :obcond_then othenbody
			     :obcond_else oelsebody
			     ))
	     )
	(multiple_put_nth oargs 0 omatdata)
	(multiple_put_nth oargs 1 omatched)
	(foreach_in_multiple
	 (oins)
	 (curins :long inix)
	 (multiple_put_nth oargs (+i inix 2) curins)
	 )
	;; add the clear of all the outs in the else branch
	(foreach_in_multiple
	 (oouts)
	 (curouts :long outix)
	 (let ( (obcl (instance class_objclear
				:obi_loc mloc
				:oclr_vloc curouts)) )
	   (debug "compilmatcher_funmatcher obcl=" obcl)
	   (list_append oelselist obcl)
	 ))
	;; dispose the temporary variables
	(dispose_objloc otestres gcx)
	(dispose_objloc otestclos gcx)
	;; add the final gotos
	(list_append othenlist (get_field :mcx_gotothen mcx))
	(list_append oelselist (get_field :mcx_gotoelse mcx))
	(debug "compilmatcher_funmatcher ogetclos=" ogetclos 
	       " omapp=" omapp " ocond=" ocond)
	(list_append olist ogetclos)
	(list_append olist omapp)
	(list_append olist ocond)
	)
      )
    ))
(install_method class_funmatcher compile_matcher compilmatcher_funmatcher)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; eof warmelt-genobj.melt