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

;; file warmelt-outobj.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright (C) 2008 - 2012 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-outobj.melt and 
;; to the generated file  warmelt-outobj*.c
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

;; the limit for our [generated C code] implementation and declaration
;; buffer length. The biggest file is often one of
;; melt-stage2/warmelt*c or one of melt-sources/xtramelt*c. 9Mbytes is
;; not enough!
(definstance buffer_limit_cont class_reference
  :referenced_value '33554432)		;; 2^25


(defun get_code_buffer_limit () 
  :doc #{Function to retrieve the generated code buffer limit. 
See also $PUT_CODE_BUFFER_LIMIT}#
  !buffer_limit_cont)

(defun put_code_buffer_limit (lim)
  :doc #{Function to verbosely change the generated code buffer limit
between 2Mb and 64Mb.  See also $GET_CODE_BUFFER_LIMIT.}#
  (let ( (:long l (get_int lim))
	 )
    (debug "put_buffer_limit l=" l)
    (if (and (>=i l 2097152) 		;; 2097152 == 2^21 = 2Mbytes
	     (<=i l 134217728) 		;; 134217728 = 2^27 = 128Mbytes
	     )
	(let ( (vlim (make_integerbox discr_constant_integer l))
	       ) 
	  (code_chunk informbuflimchk 
		      #{ /*$INFORMBUFLIMCHK*/ inform (UNKNOWN_LOCATION, 
			 "MELT code buffer limit set to %ld Kb = %ld Mb", 
			 ($L) >>10, ($L) >> 20);
		      }#)
	  (set_ref buffer_limit_cont vlim)
	  )
      )))


;;;;;;;;;;;;;;;;
(defun code_buffer_limit_optset (optsymb :cstring csopt)
  (let ( (:long lim 0) )
    (code_chunk getlimchk
		#{/*$GETLIMCHK*/ $LIM = atoi($CSOPT);
		}#)
    (if (>i lim 0)
	(put_code_buffer_limit (make_integerbox discr_constant_integer 
						(*i lim 1024))))))

(register_option 'code_buffer_limit
		 '"set limit in kilobytes for the generated code buffer size"
		 code_buffer_limit_optset)


(defun outdeclinit_root (recv sbuf)
  (debug "outdeclinit_root recv=" recv)
  (assert_msg "outdeclinit_root unimplemented catchall" ())
  )
(install_method class_root output_c_declinit outdeclinit_root)


(defun outpucod_objinielem (obielem  declbuf implbuf :long depth)
  (assert_msg "check obelem" (is_a obielem class_objinitelem))
  (let ( (olocvar (unsafe_get_field :oie_locvar obielem))
	 (cnam (unsafe_get_field :oie_cname obielem)) )
    (assert_msg "check cnam" (is_string cnam))
    (assert_msg "check olocvar"  olocvar)
    (output_c_code olocvar declbuf implbuf depth)
    ;;
    (cond ( (>i (strbuf_usedlength declbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outpucod_objinielem huge declbuf" 10)
	    (debug "outpucod_objinielem huge declbuf=" declbuf)
	    (assert_msg "check limited declbuf" 
		      (<i (strbuf_usedlength declbuf) (get_int !buffer_limit_cont)))))
    ;;
    (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outpucod_objinielem huge implbuf" 10)
	    (debug "outpucod_objinielem huge implbuf=" implbuf)
	    (assert_msg "check limited implbuf" 
			(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
    )
  )
(install_method class_objinitelem output_c_code outpucod_objinielem)

(defun outcinitfill_root (recv implbuf ptrstr :long depth)
  (debug "outcinitfill_root recv=" recv)
  (assert_msg "outcinitfill_root unimplemented catchall" ())
  )
(install_method class_root output_c_initial_fill outcinitfill_root)



(defun outcinitpredef_root (recv sbuf ptrstr :long depth)
  (debug  "outcinitfill_root recv=" recv)
  (return)
  )
(install_method class_root output_c_initial_predef outcinitpredef_root)

;;; output a predef
(defun output_predef (obpr implbuf :long depth)
  (cond 
   ( (is_integerbox obpr)
     (add2sbuf_strconst implbuf "melt_fetch_predefined(")
     (add2sbuf_longdec implbuf (get_int obpr))
     (add2sbuf_strconst implbuf ")")
     )
   ( (is_a obpr class_symbol)
     (add2sbuf_strconst implbuf "((melt_ptr_t)(MELT_PREDEF(")
     (add2sbuf_string implbuf (unsafe_get_field :named_name obpr))
     (add2sbuf_strconst implbuf ")))")
     )
   ( :else
     (debug obpredef " output_predef bad obpredef=" obpredef)
     (assert_msg "invalid obpredef" ())
     )
   )
  ;;
    (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "output_predef huge implbuf" 10)
	    (debug "output_predef huge implbuf=" implbuf)
	    (assert_msg "check limited implbuf" 
			(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
  )

;;; output code for a predef
(defun outpucod_predef (obpred declbuf implbuf :long depth)
  (assert_msg "check obpredef" (is_a obpred class_objpredef))
  (let ( (obpr (unsafe_get_field :obpredef obpred)) )
    (output_predef obpr implbuf depth)))
(install_method class_objpredef output_c_code outpucod_predef)

;;;; output a nil
(defun outpucod_nil (obnil  declbuf implbuf :long depth)
  (assert_msg "check obnil" (is_a obnil class_objnil))
  (add2sbuf_strconst implbuf "(/*nil*/NULL)"))
(install_method class_objnil output_c_code outpucod_nil)


(defun outdeclinit_objinitobject (recv sbuf)
  (add2sbuf_strconst sbuf " struct MELT_OBJECT_STRUCT(")
  (add2sbuf_longdec sbuf (get_int recv))
  (add2sbuf_strconst sbuf ") ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")		;
  )
(install_method class_objinitobject output_c_declinit outdeclinit_objinitobject)



;; initial fill for both objinitobject & its objinituniqueobject subclass
(defun outcinitfill_objinitobject (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitobject check recv" (is_a recv class_objinitobject))
  (debug "outcinitfill_objinitobject recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitobject check ptrstr" (is_string ptrstr))
  (let ( (odata (unsafe_get_field :oie_data recv)) 
	 (odiscr (unsafe_get_field :oie_discr recv))
	 (oname (unsafe_get_field :oie_cname recv))
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (oiopredef (unsafe_get_field :oio_predef recv))
	 (oclass (get_field :oio_class recv))
	 (:long depthp1 (+i depth 1))
	 )
    (debug "outcinitfill_objinitobject odata=" odata)
    (if odata (assert_msg "check odata" (is_a odata class_nrep_datainstance)))
    (let ( (odloc (if odata (unsafe_get_field :nrep_loc odata)))
	   (odhash (if odata (unsafe_get_field :ninst_hash odata)))
	   (odslots (if odata (unsafe_get_field :ninst_slots odata)))
	   (odobnum (if odata (unsafe_get_field :ninst_objnum odata)))
	   (:long nbslots
		  (cond  ( (is_multiple odslots)
			   (multiple_length odslots))
			 ( (is_a oclass class_class)
			   (multiple_length (get_field :class_fields oclass)))
			 (:else
			  (assert_msg "outcinitfill_objinitobject cannot compute nbslots" ())
			  0)))
	   )
      (if odloc (output_location odloc sbuf depthp1 "iniobj"))
      (add2sbuf_indentnl sbuf depth)
      (add2sbuf_strconst sbuf "/*iniobj ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "*/")
      (add2sbuf_indentnl sbuf depth)
      (if oiopredef
	  (progn
	    (add2sbuf_strconst sbuf "if (")
	    (output_predef oiopredef sbuf depth)
	    (add2sbuf_strconst sbuf " != (melt_ptr_t)&")
	    (add2sbuf_string sbuf ptrstr)
	    (add2sbuf_strconst sbuf "->")
	    (add2sbuf_string sbuf oname)
	    (add2sbuf_strconst sbuf ") {")
	    (add2sbuf_indentnl sbuf depthp1)
	    (if nbslots
		(progn
		  (add2sbuf_strconst sbuf "melt_assertmsg(\"check.predef length ")
		  (output_predef oiopredef sbuf depthp1)
		  (add2sbuf_strconst sbuf "\", melt_object_length((melt_ptr_t)(")
		  (output_predef oiopredef sbuf depthp1)
		  (add2sbuf_strconst sbuf ")) >= ")
		  (add2sbuf_longdec sbuf nbslots)
		  (add2sbuf_strconst sbuf ");")
		  (add2sbuf_indentnl sbuf depthp1)))
	    (add2sbuf_strconst sbuf "};")
	    (add2sbuf_indentnl sbuf depth)
	    (output_c_code olocvar () sbuf depth)
	    (add2sbuf_strconst sbuf " = ")
	    (output_predef oiopredef sbuf depth)
	    (add2sbuf_strconst sbuf ";")
	    (add2sbuf_indentnl sbuf depth)
	    )
	(progn
	  ;; for unique objects, only set locvar if it was not set;
	  ;; hence already existing symbols are not recreated
	  (if (is_a recv class_objinituniqueobject)
	      (progn
		(add2sbuf_strconst sbuf "/*uniqueobj*/ if (!")
		(output_c_code olocvar () sbuf depth)
		(add2sbuf_strconst sbuf ") ")
		(add2sbuf_indentnl sbuf depth)
		))
	  (output_c_code olocvar () sbuf (+i depth 1))
	  (add2sbuf_strconst sbuf " = (melt_ptr_t )&")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf oname)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf depth)
	  ))
      ;; Generate the check that odiscr is an object.  We generate a
      ;; test for melt_prohibit_garbcoll because code generated for
      ;; warmelt-first.melt temporarily violate the check, since all
      ;; major classes are not initialized at that time.
      (add2sbuf_strconst sbuf " if (MELT_LIKELY(!melt_prohibit_garbcoll)) melt_assertmsg(\"iniobj check.discr isobj ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "\", melt_magic_discr ((melt_ptr_t) (")
      (output_c_code odiscr () sbuf depth)
      (add2sbuf_strconst sbuf ")) == MELTOBMAG_OBJECT);")
      (add2sbuf_indentnl sbuf (+i depth 1)) 
      ;; generate the check of the objnum of odiscr
      (add2sbuf_strconst sbuf " if (MELT_LIKELY(!melt_prohibit_garbcoll)) melt_assertmsg(\"iniobj check.discr objmagic ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "\", ((meltobject_ptr_t) (")
      (output_c_code odiscr () sbuf depth)
      (add2sbuf_strconst sbuf "))->meltobj_magic == MELTOBMAG_OBJECT);")
      (add2sbuf_indentnl sbuf (+i depth 1))
      ;; generate the initialization of the class
      (add2sbuf_string sbuf ptrstr)
      (add2sbuf_strconst sbuf "->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".meltobj_class = (meltobject_ptr_t)(")
      (output_c_code odiscr () sbuf depth)
      (add2sbuf_strconst sbuf ");")
      (add2sbuf_indentnl sbuf depth)
      (if odobnum
	  (progn
	    (add2sbuf_strconst sbuf " ")
	    (add2sbuf_string sbuf ptrstr)
	    (add2sbuf_strconst sbuf "->")
	    (add2sbuf_string sbuf oname)
	    (add2sbuf_strconst sbuf ".obj_num = ")
	    (cond ( (is_integerbox odobnum)
		    (add2sbuf_longdec sbuf (get_int odobnum)))
		  ( (is_a odobnum class_symbol)
		    (add2sbuf_string sbuf (unsafe_get_field :named_name odobnum)))
		  (:else 
		   (debug "outcinitfill_objinitobject unexpected odobnum=" odobnum)
		   (assert_msg "outcinitfill_objinitobject unexpected odobnum" ())
		   ))
	    (add2sbuf_strconst sbuf ";")
	    (add2sbuf_indentnl sbuf depth)
	    ))
      (add2sbuf_strconst sbuf " ")
      (add2sbuf_string sbuf ptrstr)
      (add2sbuf_strconst sbuf "->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".obj_hash = ")
      (if odhash 
	  (add2sbuf_longdec sbuf (get_int odhash))
	(add2sbuf_strconst sbuf "melt_nonzerohash ()"))
      (add2sbuf_strconst sbuf ";")
      (add2sbuf_indentnl sbuf depth)
      (add2sbuf_strconst sbuf " ")
      (add2sbuf_string sbuf ptrstr)
      (add2sbuf_strconst sbuf "->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".obj_len = ")
      (add2sbuf_longdec sbuf nbslots)
      (add2sbuf_strconst sbuf ";")
      (add2sbuf_indentnl sbuf depth)
      ;; output the fill
      )
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (debug "outcinitfill_objinitobject huge sbuf=" sbuf)
	    (assert_msg "check limited sbuf" 
			(<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    )
  )
(install_method class_objinitobject output_c_initial_fill outcinitfill_objinitobject)




(defun outcinitpredef_objinitobject (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitpredef_objinitobject check recv" (is_a recv class_objinitobject))
  (debug recv "outcinitpredef_objinitobject recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitpredef_objinitobject check sbuf" (is_strbuf sbuf))
  (assert_msg "outcinitpredef_objinitobject check ptrstr" (is_string ptrstr))
  (let ( (odata (unsafe_get_field :oie_data recv)) 
	 (odiscr (unsafe_get_field :oie_discr recv))
	 (oname (unsafe_get_field :oie_cname recv))
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (oiopredef (unsafe_get_field :oio_predef recv))
	 )
    (assert_msg "check odata" (is_a odata class_nrep_datainstance))
    (debug "outcinitpredef_objinitobject oiopredef=" oiopredef)
    (if (null oiopredef) (return ()))
    (if (is_a oiopredef class_nrep_nil) (return ()))
    (let ( (odloc (unsafe_get_field :nrep_loc odata))
	   )
      (output_location odloc sbuf depth "inipredef")
      (add2sbuf_strconst sbuf "/*inipredef ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "*/")
      (add2sbuf_indentnl sbuf depth)
      ;;
      (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	      (debug "outcinitpredef_objinitobject huge implbuf=" sbuf)
	      (assert_msg "check limited sbuf" 
			  (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
      ;; we really initialize the predefined only if it was not initialized
      (cond
       ( (is_a oiopredef class_symbol)
	 (add2sbuf_strconst sbuf "if (!MELT_PREDEF(")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ")) MELT_STORE_PREDEF(")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ", (melt_ptr_t)&")
	 (add2sbuf_string sbuf ptrstr)
	 (add2sbuf_strconst sbuf "->")
	 (add2sbuf_string sbuf oname)
	 (add2sbuf_strconst sbuf ");")
	 (add2sbuf_indentnl sbuf 1)
	 (add2sbuf_strconst sbuf "else {")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "MELTPREDEFIX(meltpredefinited,")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ") = 1;")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "fnotice(stderr, \"MELT: predefined %s already defined <%s:%d>\\n\", \"")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf "\", __FILE__, __LINE__);")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "};")
	 (add2sbuf_indentnl sbuf 1)
	 )
       ( (is_integerbox oiopredef)
	 (add2sbuf_strconst sbuf "if (!melt_fetch_predefined(")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf ")) melt_store_predefined(")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf ", (melt_ptr_t)&")
	 (add2sbuf_string sbuf ptrstr)
	 (add2sbuf_strconst sbuf "->")
	 (add2sbuf_string sbuf oname)
	 (add2sbuf_strconst sbuf ");")
	 (add2sbuf_indentnl sbuf 1)
	 (add2sbuf_strconst sbuf "else {")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "meltpredefinited[")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf "] = 1;")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "fnotice(\"MELT: predefined #%d already defined <%s:%d>\\n\", ")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf ", __FILE__, __LINE__);")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "};")
	 (add2sbuf_indentnl sbuf 1)
;;;
	 )
       ( (null oiopredef)
	 (return ()))
       ( :else
	 (debug "outcinitpredef_objinitobject unexpected oiopredef=" oiopredef)
	 (assert_msg "outcinitpredef_objinitobject unexpected oiopredef" ())
	 )))
    )
  )

(install_method class_objinitobject output_c_initial_predef outcinitpredef_objinitobject)



(defun outdeclinit_objinitmultiple (recv sbuf)
  (add2sbuf_strconst sbuf " struct MELT_MULTIPLE_STRUCT(")
  (add2sbuf_longdec sbuf (get_int recv))
  (add2sbuf_strconst sbuf ") ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitmultiple output_c_declinit outdeclinit_objinitmultiple)


(defun outcinitfill_objinitmultiple (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitmultiple check recv" (is_a recv class_objinitmultiple))
  (debug "outcinitfill_objinitmultiple recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitmultiple check ptrstr" (is_string ptrstr))
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 )
    (add2sbuf_strconst sbuf "/*inimult ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf 1)
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf 1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".nbval = ")
    (add2sbuf_longdec sbuf (get_int recv))
    (add2sbuf_strconst sbuf ";")
    ;;
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outcinitfill_objinitmultiple huge sbuf" 15)
	    (debug "outcinitfill_objinitmultiple huge sbuf=" sbuf)
	    (assert_msg "check limited sbuf" 
			(<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    ))
(install_method class_objinitmultiple output_c_initial_fill outcinitfill_objinitmultiple)

(defun outdeclinit_objinitclosure (recv sbuf)
  (add2sbuf_strconst sbuf " struct MELT_CLOSURE_STRUCT(")
  (add2sbuf_longdec sbuf (get_int recv))
  (add2sbuf_strconst sbuf ") ")
  (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitclosure output_c_declinit outdeclinit_objinitclosure)

(defun outcinitfill_objinitclosure (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitclosure check recv" (is_a recv class_objinitclosure))
  (debug "outcinitfill_objinitclosure recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitclosure check ptrstr" (is_string ptrstr))
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (orout (unsafe_get_field :oiclo_rout recv))
	 (:long depthp1 (+i 1 depth))
	 )
    (add2sbuf_strconst sbuf "/*iniclos ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf depthp1)
    (if olocvar
	(progn
					; (add2sbuf_strconst sbuf "/*inicloslocvar*/ ")
	  (output_c_code olocvar () sbuf depthp1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf depthp1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf depthp1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf depthp1)
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".nbval = ")
    (add2sbuf_longdec sbuf (get_int recv))
    (add2sbuf_strconst sbuf ";")
    (add2sbuf_indentnl sbuf depthp1)
    (if orout
	(progn
	  (add2sbuf_strconst sbuf " ")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ".rout = (meltroutine_ptr_t) (")
	  (output_c_code orout () sbuf depthp1)
	  (add2sbuf_strconst sbuf ");")
	  (add2sbuf_indentnl sbuf depthp1)
	  ))
    ;;
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (debug "outcinitfill_objinitclosure huge sbuf=" sbuf)
	    (shortbacktrace_dbg "outcinitfill_objinitclosure huge sbuf" 15)
	    (assert_msg "check limited sbuf" 
			(<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    ))
(install_method class_objinitclosure output_c_initial_fill outcinitfill_objinitclosure)


(defun outdeclinit_objinitroutine (recv sbuf)
  (add2sbuf_strconst sbuf " struct MELT_ROUTINE_STRUCT(")
  (add2sbuf_longdec sbuf (get_int recv))
  (add2sbuf_strconst sbuf ") ")
  (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitroutine output_c_declinit outdeclinit_objinitroutine)


(defun outcinitfill_objinitroutine (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitroutine check recv" (is_a recv class_objinitroutine))
  (debug recv "outcinitfill_objinitroutine recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitroutine check ptrstr" (is_string ptrstr))
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (ipro (unsafe_get_field :oir_procroutine recv))
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (ndatr (unsafe_get_field :oie_data recv))
	 )
    (add2sbuf_strconst sbuf "/*inirout ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf 1)
    (if olocvar
	(progn
					; (add2sbuf_strconst sbuf "/*iniroutlocvar*/ ")
	  (output_c_code olocvar () sbuf 1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " strncpy (")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".routdescr, \"")
    (if (is_a ndatr class_nrep_dataroutine)
	(let ( (dnam (unsafe_get_field :ndata_name ndatr))
	       (dpro (unsafe_get_field :ndrou_proc ndatr))
	       )
	  (debug ndatr "outcinitfill_objinitroutine ndatr=" ndatr " dpro=" dpro)
	  (if (is_a dnam class_named)
	      (add2sbuf_cencstring sbuf (unsafe_get_field :named_name dnam)))
	  (if (is_a dpro class_nrep_routproc)
	      (let (  (dloc (unsafe_get_field :nrep_loc dpro))
		      (locfil (or (mixint_val dloc) (mixloc_val dloc)))
		      )
		(add2sbuf_strconst sbuf " @")
		(add2sbuf_cencstring sbuf locfil)
		(add2sbuf_strconst sbuf ":")
		(add2sbuf_longdec sbuf (get_int dloc))
		)
	    )
	  )
      (add2sbuf_cencstring sbuf cnam))
    (add2sbuf_strconst sbuf "\",  MELT_ROUTDESCR_LEN - 1);")
    (add2sbuf_indentnl sbuf 1)   
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".nbval = ")
    (add2sbuf_longdec sbuf (get_int recv))
    (add2sbuf_strconst sbuf ";")
    (add2sbuf_indentnl sbuf 1)
    (if ipro
	(progn
	  (debug "outcinitfill_objinitroutine ipro=" ipro)
	  (assert_msg "check ipro" (is_a ipro class_named))
	  (add2sbuf_strconst sbuf "MELT_ROUTINE_SET_ROUTCODE(&")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ", ")
	  (add2sbuf_string sbuf (unsafe_get_field :named_name ipro))
	  (add2sbuf_strconst sbuf ");")
	  (add2sbuf_indentnl sbuf 1)
	  )
      (progn
	(debug "outcinitfill_objinitroutine (noipro) recv=" recv)
	(add2sbuf_strconst sbuf "#warning no procedure in objinitroutine ")
	(add2sbuf_string sbuf cnam)
	(add2sbuf_indentnl sbuf 1)
	)
      )
    )
  ;;
  (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	  (debug "outcinitfill_objinitroutine huge sbuf=" sbuf)
	  (shortbacktrace_dbg "outcinitfill_objinitroutine huge sbuf" 12)
	  (assert_msg "check limited sbuf" 
	      (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
  )
(install_method class_objinitroutine output_c_initial_fill outcinitfill_objinitroutine)


;;;; strings
(defun outdeclinit_objinitstring (recv sbuf)
  (add2sbuf_strconst sbuf " struct MELT_STRING_STRUCT(")
  (add2sbuf_longdec sbuf (get_int recv))
  (add2sbuf_strconst sbuf ") ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitstring output_c_declinit outdeclinit_objinitstring)


(defun outcinitfill_objinitstring (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitstring check recv" (is_a recv class_objinitstring))
  (debug  "outcinitfill_objinitstring recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitstring check ptrstr" (is_string ptrstr))
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (strdata (unsafe_get_field :oie_data recv))
	 (:long datalen (string_length strdata))
	 )
    (add2sbuf_indentnl sbuf depth)
    (add2sbuf_strconst sbuf "/*inistring ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf (+i depth 1))
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf 1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    ;; we handle big enough strings specially
    (if (<i datalen 256)
	(progn 
	  (add2sbuf_strconst sbuf "/*small inistring*/ strncpy(")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ".val, \"")
	  (add2sbuf_cencstring sbuf strdata)
	  (add2sbuf_strconst sbuf "\", sizeof (") 
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ".val)-1);")
	  )
      ;; else datalen > 256
;;;;;;;;;;;;;;;;
      ;; the C standard gives some limitation on constant strings. We
      ;; avoid generating a huge constant string as single source to a
      ;; strcpy. We break that in a sequence of memcpy on big chunks
      ;; ended by a smaller strcpy.
      (let ( (:long ix 0)
	     )
	(debug "outcinitfill_objinitstring big datalen=" datalen)
	(add2sbuf_strconst sbuf "/*big inistring*/")
	(add2sbuf_indentnl sbuf 1)
	(forever
	 inistrloop
	 (debug "outcinitfill_objinitstring ix=" ix " sbuflen=" (strbuf_usedlength sbuf))
	 ;;
	 (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
		 (shortbacktrace_dbg "outcinitfill_objinitstring huge sbuf" 10)
		 (debug "outcinitfill_objinitstring huge sbuf=" sbuf)
		 (assert_msg "check limited sbuf" 
			     (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
	 ;;
	 (cond
	  ;; end reached
	  ((>=i ix datalen) 
	   (exit inistrloop))
	  ;; end nearly reached
	  ((>i (+i ix 72) datalen)
	   (add2sbuf_strconst sbuf "/*end big inistring*/ strncpy(")
	   (add2sbuf_string sbuf ptrstr)
	   (add2sbuf_strconst sbuf "->")
	   (add2sbuf_string sbuf cnam)
	   (add2sbuf_strconst sbuf ".val + ")
	   (add2sbuf_longdec sbuf ix)
	   (add2sbuf_strconst sbuf ", \"")
	   (add2out_cencsubstring sbuf strdata ix (-i datalen ix))
	   (add2sbuf_strconst sbuf "\", sizeof (") 
	   (add2sbuf_string sbuf ptrstr)
	   (add2sbuf_strconst sbuf "->")
	   (add2sbuf_string sbuf cnam)
	   (add2sbuf_strconst sbuf ".val) - ")
	   (add2sbuf_longdec sbuf (+i ix 1))
	   (add2sbuf_strconst sbuf ");")
	   (add2sbuf_indentnl sbuf 1)
	   (exit inistrloop)
	   )
	  ;; very big remaining
	  ((<i ix (-i datalen 256))
	   (add2sbuf_strconst sbuf "/*really big chunk inistring*/")
	   (add2sbuf_indentnl sbuf 1)
	   (add2sbuf_strconst sbuf "memcpy (")
	   (add2sbuf_string sbuf ptrstr)
	   (add2sbuf_strconst sbuf "->")
	   (add2sbuf_string sbuf cnam)
	   (add2sbuf_strconst sbuf ".val + ")
	   (add2sbuf_longdec sbuf ix)
	   (add2sbuf_strconst sbuf ",")
	   ;; compile time catanation of constant string
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata ix 64)
	   (add2sbuf_strconst sbuf "\"")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata (+i 64 ix) 64)
	   (add2sbuf_strconst sbuf "\"")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata (+i 128 ix) 64)
	   (add2sbuf_strconst sbuf "\"")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata (+i 192 ix) 64)
	   (add2sbuf_strconst sbuf "\",")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf " /*big*/ 256);")
	   (add2sbuf_indentnl sbuf 1)
	   ;;(setq ix (+i ix 256))
	   (increment ix 256)
	   (void)
	   )
	  ;; less big remaining
	  ((<i ix (-i datalen 128))
	   (add2sbuf_strconst sbuf "/*quite big chunk inistring*/")
	   (add2sbuf_indentnl sbuf 1)
	   (add2sbuf_strconst sbuf "memcpy (")
	   (add2sbuf_string sbuf ptrstr)
	   (add2sbuf_strconst sbuf "->")
	   (add2sbuf_string sbuf cnam)
	   (add2sbuf_strconst sbuf ".val + ")
	   (add2sbuf_longdec sbuf ix)
	   (add2sbuf_strconst sbuf ",")
	   ;; compile time catanation of constant string
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata ix 64)
	   (add2sbuf_strconst sbuf "\"")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata (+i 64 ix) 64)
	   (add2sbuf_strconst sbuf "\",")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf " /*lessbig*/ 128);")
	   (add2sbuf_indentnl sbuf 1)
	   (increment ix 128)
	   ;;(setq ix (+i ix 128))
	   (void)
	   )
	  ;; even less big remaining
	  ((<i ix (-i datalen 64))
	   (add2sbuf_strconst sbuf "/*almost big chunk inistring*/")
	   (add2sbuf_indentnl sbuf 1)
	   (add2sbuf_strconst sbuf "memcpy (")
	   (add2sbuf_string sbuf ptrstr)
	   (add2sbuf_strconst sbuf "->")
	   (add2sbuf_string sbuf cnam)
	   (add2sbuf_strconst sbuf ".val + ")
	   (add2sbuf_longdec sbuf ix)
	   (add2sbuf_strconst sbuf ",")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf "\"")
	   (add2out_cencsubstring sbuf strdata ix 64)
	   (add2sbuf_strconst sbuf "\",")
	   (add2sbuf_indentnl sbuf 8)
	   (add2sbuf_strconst sbuf " /*evenlessbig*/ 64);")
	   (add2sbuf_indentnl sbuf 1)
	   (increment ix 64)
	   ;;(setq ix (+i ix 64))
	   (void)
	   )
	  )
	 (void)
	 )
	;;
	;;
	;;
	(cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
		(shortbacktrace_dbg "outcinitfill_objinitstring huge sbuf" 10)
		(debug "outcinitfill_objinitstring huge declbuf=" sbuf)
		(assert_msg "check limited sbuf" 
			    (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
	))
	(add2sbuf_indentnl sbuf 1)
	(add2out sbuf ##{$PTRSTR->$CNAM.val[$DATALEN] = (char)0; }#
		 )
	(add2sbuf_indentnl sbuf 1)
	(add2out sbuf ##{$PTRSTR->$CNAM.slen = $DATALEN; }#
		 )
	(add2sbuf_indentnl sbuf 1)
    ))
(install_method class_objinitstring output_c_initial_fill outcinitfill_objinitstring)


;;;; boxed integers
(defun outdeclinit_objinitboxedinteger (recv sbuf)
  (add2sbuf_strconst sbuf " struct meltint_st ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitboxinteger output_c_declinit outdeclinit_objinitboxedinteger)


(defun outcinitfill_objinitboxedinteger (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitboxedinteger check recv" (is_a recv class_objinitboxinteger))
  (debug "outcinitfill_objinitboxedinteger recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitboxedinteger check ptrstr" (is_string ptrstr))
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 (odata (unsafe_get_field :oie_data recv))
	 (:long depthp1 (+i 1 depth))
	 )
    (add2sbuf_strconst sbuf "/*iniboxint ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf depthp1)
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf depthp1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf depthp1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf depthp1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf depthp1)
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".val = ")
    (add2sbuf_longdec sbuf (get_int odata))
    (add2sbuf_strconst sbuf ";")
    (add2sbuf_indentnl sbuf depthp1)
    ;;
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outcinitfill_objinitboxedinteger huge sbuf" 10)
	    (debug "outcinitfill_objinitboxedinteger huge sbuf=" sbuf)
	    (assert_msg "check limited sbuf" 
			(<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    ))
(install_method class_objinitboxinteger output_c_initial_fill outcinitfill_objinitboxedinteger)




;;;; pairs
(defun outdeclinit_objinitpair (recv sbuf)
  (add2sbuf_strconst sbuf " struct meltpair_st ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitpair output_c_declinit outdeclinit_objinitpair)

(defun outcinitfill_objinitpair (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitpair check recv" (is_a recv class_objinitpair))
  (debug "outcinitfill_objinitpair recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitpair check ptrstr" (is_string ptrstr))
  (let  ( (cnam (unsafe_get_field :oie_cname recv)) 
	  (olocvar (unsafe_get_field :oie_locvar recv))
	  (odata (unsafe_get_field :oie_data recv))
	  (:long depthp1 (+i 1 depth))
	  )
    (add2sbuf_strconst sbuf "/*inipair ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf depthp1)
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf depthp1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf depthp1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf depthp1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf depth)
    ;;
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outcinitfill_objinitpair huge sbuf" 10)
	    (debug "outcinitfill_objinitpair huge sbuf=" sbuf)
	    (assert_msg "check limited sbuf" 
		      (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    ))
(install_method class_objinitpair output_c_initial_fill outcinitfill_objinitpair)
;;;;;;;;;;;;;;;;

;;;; lists
(defun outdeclinit_objinitlist (recv sbuf)
  (add2sbuf_strconst sbuf " struct meltlist_st ")
  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
  (add2sbuf_strconst sbuf ";")
  )
(install_method class_objinitlist output_c_declinit outdeclinit_objinitlist)

(defun outcinitfill_objinitlist (recv sbuf ptrstr :long depth)
  (assert_msg "outcinitfill_objinitlist check recv" (is_a recv class_objinitlist))
  (debug "outcinitfill_objinitlist recv=" recv " ptrstr=" ptrstr)
  (assert_msg "outcinitfill_objinitlist check ptrstr" (is_string ptrstr)) 
  (let  ( (cnam (unsafe_get_field :oie_cname recv)) 
	  (olocvar (unsafe_get_field :oie_locvar recv))
	  (odata (unsafe_get_field :oie_data recv))
	  (:long depthp1 (+i 1 depth))
	  )
    (add2sbuf_strconst sbuf "/*inilist ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf depthp1)
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf depthp1)
	  (add2sbuf_strconst sbuf " = (melt_ptr_t) &")
	  (add2sbuf_string sbuf ptrstr)
	  (add2sbuf_strconst sbuf "->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf depthp1)
	  ))
    (add2sbuf_strconst sbuf " ")
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (meltobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) () sbuf depthp1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf depth)
    ;;
    (cond ( (>i (strbuf_usedlength sbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outcinitfill_objinitlist huge sbuf" 10)
	    (debug "outcinitfill_objinitlist huge sbuf=" sbuf)
	    (assert_msg "check limited sbuf" 
		      (<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))))
    )
  )
(install_method class_objinitlist output_c_initial_fill outcinitfill_objinitlist)
;;;;;;;;;;;;;;;;

(defun outpucod_anydiscr (any declbuf implbuf :long depth)
  (debug "outpucod_anydiscr any=" any)
  (outcstring_err "* output_c_code unimplemented receiver discriminator ")
  (let ( (discr (discrim any)) ) 
    (outstr_err (unsafe_get_field :named_name discr))
       (outnewline_err)
       (debug  "outpucod_anydiscr discr=" discr))
  (assert_msg "@@ outpucod_anydiscr not able to output" ())
  )
(install_method discr_any_receiver output_c_code outpucod_anydiscr)

(defun outpucod_null (nul declbuf implbuf :long depth)
  (add2sbuf_strconst implbuf "NULL")
  )
(install_method discr_null_receiver output_c_code outpucod_null)

;;; catchall for outputting any stuff
(defun outpucod_catchall_root (anyr declbuf implbuf :long depth)
  (debug anyr "outpucod_catchall_root anyr=" anyr)
  (display_debug_message anyr "outpucod_catchall_root anyr")
  (outcstring_err "* output_c_code unimplemented receiver class ")
  (let ( (discr (discrim anyr)) ) (outstr_err (unsafe_get_field :named_name discr)))
  (outnewline_err)
  (assert_msg "@@ outpucod_catchall_root not able to output" ())
  )
(install_method class_root output_c_code outpucod_catchall_root)

;;; common code to output a location

;;; just output the #line directive
(defun output_raw_location (loc implbuf :long depth :cstring msg)
  (if loc
      (progn
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#ifndef MELTGCC_NOLINENUMBERING")
	(add2sbuf_indentnl implbuf 0)
	(cond ( (is_mixint loc) 
;;; we don't output #line in a single draw to make
;;; grep -v '#line' work better even without the
;;; start-of-line caret...
		(add2sbuf_strconst implbuf "#")
		(add2sbuf_strconst implbuf "line ")
		(add2sbuf_longdec implbuf (get_int loc))
		(add2sbuf_strconst implbuf " \"")
		(add2sbuf_string implbuf (mixint_val loc))
		(add2sbuf_strconst implbuf "\""))
	      ( (is_mixloc loc)
		(add2sbuf_strconst implbuf "#")
		(add2sbuf_strconst implbuf "line ")
		(add2sbuf_longdec implbuf (mixloc_locline loc))
		(add2sbuf_strconst implbuf "   \"")
		(add2sbuf_strconst implbuf (mixloc_locbasefile loc))
		(add2sbuf_strconst implbuf "\""))
	      )
	(if msg 
	    (progn
	      (add2sbuf_strconst implbuf " /**::")
	      (add2sbuf_ccomconst implbuf msg)
	      (add2sbuf_strconst implbuf "::**/")
	      ))
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#endif /*MELTGCC_NOLINENUMBERING*/")
	(add2sbuf_indentnl implbuf depth)
	;;
	(cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
		(shortbacktrace_dbg "output_raw_location huge implbuf" 12)
		(debug "output_raw_location huge implbuf=" implbuf)
		(assert_msg "check limited implbuf" 
			    (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
	)))

;; we really want to avoid outputint the same location twice, so we
;; keep the previous location and implbuf

(definstance prevloc_container class_reference)
(definstance previmplbuf_container class_reference)

;; return the line number and file name of a location
(defun line_and_file_of_location (loc)
  (cond
   ( (is_mixint loc) 
     (return (make_integerbox discr_integer (get_int loc))
	     (mixint_val loc))
     )
   ( (is_mixloc loc)
     (return (make_integerbox discr_integer  (mixloc_locline loc))
	     (make_string_mixloc_file discr_string loc)))
   ( :else
     (return () ()))
   )
  )

;; output the location & set the frame's location
(defun output_location (loc implbuf :long depth :cstring msg)
  (let ( (prevloc (unsafe_get_field :referenced_value prevloc_container))
	 (prevbuf (unsafe_get_field :referenced_value previmplbuf_container))
	 )
    (if (== prevbuf implbuf)
	(if (or (== prevloc loc)
		(and (==i (get_int loc) (get_int prevloc))
		     (== (mixloc_val loc) (mixloc_val prevloc))))
	    (progn
	      (if msg (progn 
			(add2sbuf_strconst implbuf "/*^")
			(add2sbuf_ccomconst implbuf msg)
			(add2sbuf_strconst implbuf "*/")
			))
	      (add2sbuf_indentnl implbuf 0)
	      (add2sbuf_strconst implbuf "#ifndef MELTGCC_NOLINENUMBERING")
	      (add2sbuf_indentnl implbuf 0)
	      (cond ( (is_mixint loc) 
;;; we don't output #line in a single draw to make
;;; grep -v '#line' work better even without the
;;; start-of-line caret...
		      (add2sbuf_strconst implbuf "#")
		      (add2sbuf_strconst implbuf "line ")
		      (add2sbuf_longdec implbuf (get_int loc))
		      )
		    ( (is_mixloc loc)
		      (add2sbuf_strconst implbuf "#")
		      (add2sbuf_strconst implbuf "line ")
		      (add2sbuf_longdec implbuf (mixloc_locline loc))
		      )
		    )
	      (add2sbuf_indentnl implbuf 0)
	      (add2sbuf_strconst implbuf "#endif")
	      (add2sbuf_indentnl implbuf depth)
	      ;;
	      (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
		      (shortbacktrace_dbg "output_location huge implbuf" 12)
		      (debug "output_location huge implbuf=" implbuf)
		      (assert_msg "check limited implbuf" 
				  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
	      (return)
	      )
	  )
      )
    (unsafe_put_fields  prevloc_container :referenced_value loc)
    (unsafe_put_fields  previmplbuf_container :referenced_value implbuf)
    ;;
    (cond
     ( (is_mixint loc) 
       (add2sbuf_strconst implbuf "MELT_LOCATION(\"")
       (add2sbuf_string implbuf (mixint_val loc))
       (add2sbuf_strconst implbuf ":")
       (add2sbuf_longdec implbuf (get_int loc))
       (if msg (progn
		 (add2sbuf_strconst implbuf ":/ ")
		 (add2sbuf_strconst implbuf msg)
		 ))
       (add2sbuf_strconst implbuf "\");")
       )
     ( (is_mixloc loc)
       (add2sbuf_strconst implbuf "MELT_LOCATION(\"")
       (add2sbuf_string implbuf (mixloc_val loc))
       (add2sbuf_strconst implbuf ":")
       (add2sbuf_longdec implbuf (get_int loc))
       (if msg (progn
		 (add2sbuf_strconst implbuf ":/ ")
		 (add2sbuf_strconst implbuf msg)
		 ))
       (add2sbuf_strconst implbuf "\");")
       )
     )
    (output_raw_location loc implbuf depth msg)
    ))


;;; output the code for declaring the current frame struct
(defun output_curframe_declstruct (rou dsbuf)
  (let (
	(obody (unsafe_get_field :obrout_body rou))
	(onbval (unsafe_get_field :obrout_nbval rou))
	(onblong (unsafe_get_field :obrout_nblong rou))
	(:long nbval (get_int onbval))
	(:long nblong (get_int onblong))
	(:long isinitial (is_a rou class_initialroutineobj))
	(others (unsafe_get_field :obrout_others rou))
	)       
    ;; output the current frame
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf " struct ")
    (if (is_a rou class_named)
	(progn
	  (add2sbuf_strconst dsbuf "frame_")
	  (add2sbuf_string dsbuf (unsafe_get_field :named_name rou))
	  (add2sbuf_strconst dsbuf "_st ")))
    (add2sbuf_strconst dsbuf "{")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  int mcfr_nbvar;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#if MELT_HAVE_DEBUG")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  const char* mcfr_flocs;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#else /*!MELT_HAVE_DEBUG*/")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  const char* mcfr_unusedflocs;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#endif /*MELT_HAVE_DEBUG*/")
    (add2sbuf_indentnl dsbuf 0)
    ;; we declare a mcfr_initforwmarkrout to be sure to never use clos in the
    ;; generated code; if we do, the generated code is invalid C
    (if isinitial
	(add2sbuf_strconst dsbuf
			   " void (*mcfr_initforwmarkrout) ( struct melt_callframe_st*, int);")
      (add2sbuf_strconst dsbuf "  struct meltclosure_st *mcfr_clos;"))
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  struct excepth_melt_st *mcfr_exh;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  struct melt_callframe_st *mcfr_prev;")
    (add2sbuf_indentnl dsbuf 0)
    (if (>i nbval 0) 
	(progn
	  (add2sbuf_strconst dsbuf "#define MELTFRAM_NBVARPTR ")
	  (add2sbuf_longdec dsbuf nbval)
	  (add2sbuf_indentnl dsbuf 0)
	  (add2sbuf_strconst dsbuf " melt_ptr_t mcfr_varptr[")
	  (add2sbuf_longdec dsbuf nbval)
	  (add2sbuf_strconst dsbuf "];")
	  (add2sbuf_indentnl dsbuf 0))
      (progn
	(add2sbuf_strconst dsbuf "/*no varptr*/")
	(add2sbuf_indentnl dsbuf 0)
	(add2sbuf_strconst dsbuf "#define MELTFRAM_NBVARPTR /*none*/0")
	(add2sbuf_indentnl dsbuf 0)))
    (if (>i nblong 0)
	(progn
	  (add2sbuf_strconst dsbuf "#define MELTFRAM_NBVARNUM ")
	  (add2sbuf_longdec dsbuf nblong)
	  (add2sbuf_indentnl dsbuf 0)
	  (add2sbuf_strconst dsbuf "  long mcfr_varnum[")
	  (add2sbuf_longdec dsbuf nblong)
	  (add2sbuf_strconst dsbuf "];")
	  (add2sbuf_indentnl dsbuf 0))
      (progn
	(add2sbuf_strconst dsbuf "/*no varnum*/")
	(add2sbuf_indentnl dsbuf 0)
	(add2sbuf_strconst dsbuf "#define MELTFRAM_NBVARNUM /*none*/0")
	(add2sbuf_indentnl dsbuf 0)))
    (if others 
	(progn
	  (add2sbuf_strconst dsbuf "/*others*/")
	  (add2sbuf_indentnl dsbuf 0)
	  (list_every 
	   others
	   (lambda (oloc)
	     (assert_msg "check other oloc" (is_a oloc class_objlocv))
	     (let ( (octyp (unsafe_get_field :obv_type oloc))
		    (oname (unsafe_get_field :obl_cname oloc))
		    )
	       (assert_msg "check octyp" (is_a octyp class_ctype))
	       (add2sbuf_string dsbuf (unsafe_get_field :ctype_cname octyp))
	       (add2sbuf_strconst dsbuf " ")
	       (add2sbuf_string dsbuf oname)
	       (add2sbuf_strconst dsbuf ";")
	       (add2sbuf_indentnl dsbuf 0))

	     (cond ( (>i (strbuf_usedlength dsbuf) (/iraw (get_int !buffer_limit_cont) 2))
		     (shortbacktrace_dbg "output_curframe_declstruct huge dsbuf" 10)
		     (debug "output_curframe_declstruct huge dsbuf=" dsbuf)
		     (assert_msg "check limited dsbuf" 
				 (<i (strbuf_usedlength dsbuf) (get_int !buffer_limit_cont)))))
	     ))
	  )
      (progn
	(add2sbuf_strconst dsbuf "/*no others*/")
	(add2sbuf_indentnl dsbuf 0))
      )
    (add2sbuf_strconst dsbuf "  long _spare_; }")
    (add2sbuf_indentnl dsbuf 0)
    ;; end of curframe
    ))


;;; output code for marking the frame pointed by meltframptr_
(defun outpucod_marker (rou implbuf)
  (assert_msg "check rou" (is_a rou class_routineobj))
  (let ( (others (get_field :obrout_others rou))
	 (:long nbval (get_int (get_field :obrout_nbval rou)))
	 )
    (if (is_not_a rou class_initialroutineobj)
	(progn
	  (add2sbuf_string implbuf (get_field :ctype_marker ctype_value))
	  (add2sbuf_strconst implbuf " (meltframptr_->mcfr_clos);")
	  (add2sbuf_indentnl implbuf 3)))
    (add2sbuf_strconst implbuf "for(ix=0; ix<")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf "; ix++)")
    (add2sbuf_indentnl implbuf 4)
    (add2sbuf_strconst implbuf "if (meltframptr_->mcfr_varptr[ix])")
    (add2sbuf_indentnl implbuf 5)
    (add2sbuf_string implbuf (get_field :ctype_marker ctype_value))
    (add2sbuf_strconst implbuf " (meltframptr_->mcfr_varptr[ix]);")
    (add2sbuf_indentnl implbuf 3)
    (list_every 
     others
     (lambda (oloc)
       (assert_msg "check other oloc" (is_a oloc class_objlocv))
       (let ( (octyp (get_field :obv_type oloc))
	      (oname (get_field :obl_cname oloc))
	      (omarker (get_field :ctype_marker octyp))
	      )
	 (assert_msg "check octyp" (is_a octyp class_ctype))
	 (cond
	  ((is_string omarker)
	   (add2sbuf_strconst implbuf "if (meltframptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ") ")
	   (add2sbuf_string implbuf omarker)
	   (add2sbuf_strconst implbuf " (meltframptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ");")
	   (add2sbuf_indentnl implbuf 3)
	   )
	  ((is_a omarker class_named)
	   (add2sbuf_strconst implbuf "if (meltframptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ") ")
	   (add2sbuf_string implbuf (get_field :named_name omarker))
	   (add2sbuf_strconst implbuf " (meltframptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ");")
	   (add2sbuf_indentnl implbuf 3)
	   )
	  ))
       (assert_msg "check limited implbuf" 
		   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
       ))
    ;;    (add2sbuf_indentnl implbuf 1)
    ))

;;; output the code for declaring and initializing the current frame 
(defun output_curframe_declstruct_init (declstruct rou implbuf)
  (let (
	(obody (unsafe_get_field :obrout_body rou))
	(onbval (unsafe_get_field :obrout_nbval rou))
	(onblong (unsafe_get_field :obrout_nblong rou))
	(:long nbval (get_int onbval))
	(:long nblong (get_int onblong))
	(:long isinitial (is_a rou class_initialroutineobj))
	(others (unsafe_get_field :obrout_others rou))
	(rouname (get_field :named_name rou))
	)       
    ;; output call counter for debugging
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#if MELT_HAVE_DEBUG")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " static long call_counter__;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " long thiscallcounter__ ATTRIBUTE_UNUSED = ++ call_counter__;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef meltcallcount")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define meltcallcount thiscallcounter__")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#else")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef meltcallcount")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define meltcallcount 0L")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#endif")
    (add2sbuf_indentnl implbuf 0)
    (declstruct rou implbuf)
    (if (not isinitial)
	(add2sbuf_strconst implbuf "    *meltframptr_=0,"))
    (add2sbuf_strconst implbuf "    meltfram__;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define meltframe meltfram__")
    (if (not isinitial)
	(progn
	  (add2sbuf_indentnl implbuf 2)
	  (add2sbuf_strconst implbuf "if (MELT_UNLIKELY(meltxargdescr_ == MELTPAR_MARKGGC)) { /*mark for ggc*/")
	  (add2sbuf_indentnl implbuf 3)
	  (add2sbuf_strconst implbuf "int ix=0;")
	  (add2sbuf_indentnl implbuf 3)
	  (if rouname
	      (add2out implbuf "meltframptr_ = (struct frame_" rouname "_st*) meltfirstargp_;")
	    (add2sbuf_strconst implbuf "meltframptr_ = (void*)meltfirstargp_;"))
	  (add2sbuf_indentnl implbuf 3)
	  (add2out implbuf ##{  /* use arguments output_curframe_declstruct_init */
		   (void) meltclosp_;
		   (void) meltfirstargp_;
		   (void) meltxargdescr_;
		   (void) meltxargtab_;
		   (void) meltxresdescr_;
		   (void) meltxrestab_;
		   }#)
	  (outpucod_marker rou implbuf)
	  (add2sbuf_strconst implbuf "return NULL;")
	  (add2sbuf_indentnl implbuf 2)
	  (add2sbuf_strconst implbuf "}/*end markggc*/;")
	  )
      )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "  memset(&meltfram__, 0, sizeof(meltfram__));")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " meltfram__.mcfr_nbvar = ")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 0)
    (if (not isinitial)
	(progn
	  (add2sbuf_strconst implbuf "  meltfram__.mcfr_clos = meltclosp_;")
	  (add2sbuf_indentnl implbuf 0)))
    (add2sbuf_strconst implbuf " meltfram__.mcfr_prev = (struct melt_callframe_st *) melt_topframe;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " melt_topframe = (struct melt_callframe_st *) &meltfram__;")
    (add2sbuf_indentnl implbuf 0)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))

;;; output code for a procroutine
(defun outpucod_procroutine (prou declbuf implbuf :long depth)
  (assert_msg "check prou" (is_a prou class_procroutineobj))
  (let ( (onam (unsafe_get_field :named_name prou)) 
	 (obody (unsafe_get_field :obrout_body prou))
	 (onbval (unsafe_get_field :obrout_nbval prou))
	 (onblong (unsafe_get_field :obrout_nblong prou))
	 (:long nbval (get_int onbval))
	 (:long nblong (get_int onblong))
	 (others (unsafe_get_field :obrout_others prou))
	 (ogargs (unsafe_get_field :oprout_getargs prou))
	 (oretval (unsafe_get_field :obrout_retval prou))
	 (orloc (unsafe_get_field :oprout_loc prou))
	 (ofunam (unsafe_get_field :oprout_funam prou))
	 (orestnam (unsafe_get_field :oprout_restnam prou))
	 )
    (if (not (is_string ofunam)) 
	(setq ofunam '"**"))
    ;; output the declaration
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (output_raw_location orloc implbuf 0 "proc")
    (add2sbuf_indentnl declbuf 0)
    (if (or (is_mixint orloc) (is_mixloc orloc))
	(output_raw_location orloc declbuf 0 "procdecl")
      )
    (add2sbuf_strconst declbuf "melt_ptr_t MELT_MODULE_VISIBILITY ")
    (add2sbuf_string declbuf onam)
    (add2sbuf_strconst declbuf "(meltclosure_ptr_t meltclosp_,")
    (add2sbuf_strconst declbuf " melt_ptr_t meltfirstargp_,")
    (add2sbuf_strconst declbuf " const melt_argdescr_cell_t meltxargdescr_[],")
    (add2sbuf_strconst declbuf " union meltparam_un *meltxargtab_,")
    (add2sbuf_strconst declbuf " const melt_argdescr_cell_t meltxresdescr_[],")
    (add2sbuf_strconst declbuf " union meltparam_un *meltxrestab_);")
    (add2sbuf_indentnl declbuf 0)
    ;; output the implementation
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "melt_ptr_t MELT_MODULE_VISIBILITY ")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_string implbuf onam)
    (add2sbuf_strconst implbuf "(meltclosure_ptr_t meltclosp_,")
    (add2sbuf_strconst implbuf " melt_ptr_t meltfirstargp_,")
    (add2sbuf_strconst implbuf " const melt_argdescr_cell_t meltxargdescr_[],")
    (add2sbuf_strconst implbuf " union meltparam_un *meltxargtab_,")
    (add2sbuf_indentnl implbuf 5)
    (add2sbuf_strconst implbuf " const melt_argdescr_cell_t meltxresdescr_[],")
    (add2sbuf_strconst implbuf " union meltparam_un *meltxrestab_)")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (if orestnam
	(let ( (ovariadicindex  (variadic_index_idstr orestnam))
	       (ovariadiclength (variadic_length_idstr orestnam))
	       )
	  (add2sbuf_indentnl implbuf 1)
	  (add2sbuf_strconst implbuf "/*variadic*/ int ")
	  (add2sbuf_string implbuf ovariadicindex)
	  (add2sbuf_strconst implbuf " = 0, ")
	  (add2sbuf_string implbuf ovariadiclength)
	  (add2sbuf_strconst implbuf " = melt_argdescr_length (meltxargdescr_);")
	  (add2sbuf_indentnl implbuf 0)
	  ;; we generate (0+$ORESTNAM_len) to ensure that it cannot be
	  ;; set. 
	  ;;
	  ;; The melt_variadic_length & melt_variadic_index are used
	  ;; by primitives from warmelt-base.melt like variadic_index,
	  ;; variadic_length, ...
	  (add2sbuf_strconst implbuf "#define melt_variadic_length  (0+")
	  (add2sbuf_string implbuf ovariadiclength)
	  (add2sbuf_strconst implbuf ")")
	  (add2sbuf_indentnl implbuf 0)
	  (add2sbuf_strconst implbuf "#define melt_variadic_index ")
	  (add2sbuf_string implbuf ovariadicindex)
	  (add2sbuf_indentnl implbuf 0)
	  ))
 
    (add2sbuf_indentnl implbuf 2)
    (add2out implbuf "long current_blocklevel_signals_" onam "_melt =  melt_blocklevel_signals;")
    (add2sbuf_indentnl implbuf 1)
    (output_curframe_declstruct_init output_curframe_declstruct prou implbuf)
    (add2sbuf_strconst implbuf "melt_trace_start(\"")
    (add2sbuf_string implbuf ofunam)
    (add2sbuf_strconst implbuf "\", meltcallcount);")
    (add2sbuf_indentnl implbuf 0)
    ;; output the argument getting
    (add2sbuf_strconst implbuf "/*getargs*/")
    (add2sbuf_indentnl implbuf 0)
    (assert_msg "check ogargs" (is_multiple_or_null ogargs))
    (foreach_in_multiple
     (ogargs)
     (curget :long curank) 
     (add2sbuf_indentnl implbuf 1)
     (add2sbuf_strconst implbuf "/*getarg#")
     (add2sbuf_longdec implbuf curank)
     (add2sbuf_strconst implbuf "*/")
     (add2sbuf_indentnl implbuf 1)
     (output_c_code curget declbuf implbuf 1)
     ;;
     (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	     (shortbacktrace_dbg "outpucod_procroutine huge implbuf" 10)
	     (debug "outpucod_procroutine huge implbuf=" implbuf)
	     (assert_msg "check limited implbuf" 
			 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
     )					;end foreach ogargs
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " goto lab_endgetargs;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "lab_endgetargs:;")
    (add2sbuf_indentnl implbuf 0)
    ;; output the body
    (assert_msg "check obody" (is_list obody))
    (add2sbuf_strconst implbuf "/*body*/")
    (add2sbuf_indentnl implbuf 0)
    (list_every
     obody
     (lambda (curbody)
       (if (and curbody (not (is_a curbody class_objpurevalue)))
	   (progn
	     (output_c_code curbody declbuf implbuf 0)
	     (add2sbuf_indentnl implbuf 0)))
       (assert_msg "check limited implbuf" 
		   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
       ))
    ;; end of implementation
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " goto labend_rout;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "labend_rout:")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "melt_trace_end(\"")
    (add2sbuf_string implbuf ofunam)
    (add2sbuf_strconst implbuf "\", meltcallcount);")
    (add2sbuf_indentnl implbuf 1)
    (add2out implbuf " melt_blocklevel_signals = current_blocklevel_signals_" onam "_melt;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " melt_topframe = (struct melt_callframe_st*) meltfram__.mcfr_prev;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " return (melt_ptr_t)(")
    (if oretval 
	(output_c_code oretval declbuf implbuf 1)
      (add2sbuf_strconst implbuf "/*noretval*/ NULL"))
    (add2sbuf_strconst implbuf ");")
    (if orestnam
	(progn
	  (add2sbuf_indentnl implbuf 0)
	  (add2sbuf_strconst implbuf "#undef melt_variadic_length")
	  (add2sbuf_indentnl implbuf 0)
	  (add2sbuf_strconst implbuf "#undef melt_variadic_index")
	  (add2sbuf_indentnl implbuf 0)))
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef meltcallcount")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef meltfram__")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef MELTFRAM_NBVARNUM")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef MELTFRAM_NBVARPTR")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /*end ")
    (add2sbuf_string implbuf onam)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    ;;
    (cond ( (>i (strbuf_usedlength declbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outpucod_procroutine huge declbuf" 10)
	    (debug "outpucod_procroutine huge declbuf=" declbuf)
	    (assert_msg "check limited declbuf" 
			(<i (strbuf_usedlength declbuf) (get_int !buffer_limit_cont)))))
    ;;
    (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	    (shortbacktrace_dbg "outpucod_procroutine huge implbuf" 10)
	    (debug "outpucod_procroutine huge implbuf=" implbuf)
	    (assert_msg "check limited implbuf" 
			(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
    ))
(install_method class_procroutineobj output_c_code outpucod_procroutine)




;;; output the cdata structure
(defun output_curframe_cdat_struct (idatup implbuf)
  (add2sbuf_indentnl implbuf 1)
  (add2sbuf_strconst implbuf "struct cdata_st {")
  (foreach_in_multiple
   (idatup)
   (curdat :long curk) 
   (add2sbuf_indentnl implbuf 1)
   (output_c_declinit curdat implbuf))
  (add2sbuf_indentnl implbuf 0)
  (add2sbuf_strconst implbuf " long spare_;")
  (add2sbuf_indentnl implbuf 0)
  (add2sbuf_strconst implbuf "}")
  (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	  (shortbacktrace_dbg "output_curframe_cdat_struct huge implbuf" 10)
	  (debug "output_curframe_cdat_struct huge implbuf=" implbuf)
	  (assert_msg "check limited implbuf" 
		      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
  )



;;; output the cdata structure fill
(defun output_curframe_cdat_fill (idatup implbuf)
  ;; generate the allocation of cdat
  (add2sbuf_strconst implbuf " cdat = (struct cdata_st*) meltgc_allocate(sizeof(*cdat),0);")
  (add2sbuf_indentnl implbuf 1)
  (add2sbuf_strconst implbuf " melt_prohibit_garbcoll = TRUE;")
  (add2sbuf_indentnl implbuf 1)
;;;
;;; generate the initial predef of cdat
  (add2sbuf_strconst implbuf "/*initial routine predef*/")
  (add2sbuf_indentnl implbuf 1)
  (foreach_in_multiple
   (idatup)
   (curpdat :long curk) 
   (output_c_initial_predef curpdat implbuf '"cdat" 1))
;;;
;;; generate the initial filling of cdat
  (add2sbuf_strconst implbuf "/*initial routine fill*/")
  (add2sbuf_indentnl implbuf 1)
  (foreach_in_multiple
   (idatup)
   (curfil :long curk) 
   (add2sbuf_indentnl implbuf 1)
   (output_c_initial_fill curfil implbuf '"cdat" 0))
;;;;;;;
;;; initialize the variables
;;;
;;; clear the cdat for safety and renable GC
  (add2sbuf_strconst implbuf " cdat = NULL;")
  (add2sbuf_indentnl implbuf 0)
  (add2sbuf_strconst implbuf " melt_prohibit_garbcoll = FALSE;")
  (add2sbuf_indentnl implbuf 0)
;;;
  (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	  (shortbacktrace_dbg "output_curframe_cdat_fill implbuf" 10)
	  (debug "output_curframe_cdat_fill huge implbuf=" implbuf)
	  (assert_msg "check limited implbuf" 
		      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))
  )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output code for the initial module routine
(defun outpucod_initialmoduleroutine (pini declbuf implbuf :long depth)
  (debug "outpucod_initialmoduleroutine start pini=" pini
	 "\n of discrim=" (discrim pini))
  (assert_msg "check pini" (is_a pini class_initial_module_routineobj))
  (let ( 
	(idatup (unsafe_get_field :oirout_data pini)) 
	(irfill (unsafe_get_field :oirout_fill pini))
	(iprolog (unsafe_get_field :oirout_prolog pini))
	(oretval (unsafe_get_field :obrout_retval pini))
	(omodnam (unsafe_get_field :oirout_modulename pini))
	(onbval (get_field :obrout_nbval pini))
	(:long nbval (get_int onbval))
	(:long minihash (+i 1 (%iraw (obj_hash pini) 4096)))
	) 
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (add2out declbuf ##{
MELT_EXTERN  void* melt_start_this_module (void*);
 }#)
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "typedef ")
    (output_curframe_declstruct pini implbuf)
    (add2sbuf_strconst implbuf " initial_frame_st;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "static void initialize_module_meltdata_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " (initial_frame_st *iniframp__, char meltpredefinited[])")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define meltfram__  (*iniframp__)")
    (add2sbuf_indentnl implbuf 1)
    (output_curframe_cdat_struct idatup implbuf)
    (add2sbuf_strconst implbuf " *cdat = NULL;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " dbgprintf (\"start initialize_module_meltdata_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " iniframp__=%p\", (void*) iniframp__);")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "(void) meltpredefinited; /* avoid warning if non-used. */")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " melt_assertmsg (\"check module initial frame\", iniframp__->mcfr_nbvar == /*minihash*/ -")
    (add2sbuf_longdec implbuf minihash)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf 1)
;;; fill the cdat
    (output_curframe_cdat_fill idatup implbuf)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef meltfram__")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /*end initialize_module_meltdata_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    ;; emit code to tell if we have debug
    (progn
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf
			 "/* define different names when debugging or not */")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "#if MELT_HAVE_DEBUG")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "MELT_EXTERN ")
      (add2sbuf_strconst declbuf "const char meltmodule_")
      (add2sbuf_cident declbuf omodnam)
      (add2sbuf_strconst declbuf "__melt_have_debug_enabled[];")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "#define melt_have_debug_string meltmodule_")
      (add2sbuf_cident declbuf omodnam)
      (add2sbuf_strconst declbuf "__melt_have_debug_enabled")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "#else /*!MELT_HAVE_DEBUG*/")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "MELT_EXTERN const char meltmodule_")
      (add2sbuf_cident declbuf omodnam)
      (add2sbuf_strconst declbuf "__melt_have_debug_disabled[];")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "#define melt_have_debug_string meltmodule_")
      (add2sbuf_cident declbuf omodnam)
      (add2sbuf_strconst declbuf "__melt_have_debug_disabled")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_strconst declbuf "#endif /*!MELT_HAVE_DEBUG*/")
      (add2sbuf_indentnl declbuf 0)
      (add2sbuf_indentnl declbuf 0)
      ;;
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_strconst implbuf "#if MELT_HAVE_DEBUG")
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_strconst implbuf "const char meltmodule_")
      (add2sbuf_cident implbuf omodnam)
      (add2sbuf_strconst implbuf "__melt_have_debug_enabled[] = \"MELT module ")
      (add2sbuf_cencstring implbuf omodnam)
      (add2sbuf_strconst implbuf " have debug enabled\";")
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_strconst implbuf "#else /*!MELT_HAVE_DEBUG*/")
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_strconst implbuf "const char meltmodule_")
      (add2sbuf_cident implbuf omodnam)
      (add2sbuf_strconst implbuf "__melt_have_debug_disabled[] = \"MELT module ")
      (add2sbuf_cencstring implbuf omodnam)
      (add2sbuf_strconst implbuf " have debug disabled\";")
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_strconst implbuf "#endif /*MELT_HAVE_DEBUG*/")
      (add2sbuf_indentnl implbuf 0)
      )
    ;; 
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "void* melt_start_this_module (void* modargp_) {")
    (add2sbuf_indentnl implbuf 0)
    ;; generate the initial data structure
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "char meltpredefinited[MELTGLOB__LASTGLOB+8];")
    (add2sbuf_indentnl implbuf 1)
    ;; generate the initial frame
    (output_curframe_declstruct_init 
     (lambda (rou dsbuf)
       (add2sbuf_indentnl dsbuf 0)
       (add2sbuf_strconst dsbuf "initial_frame_st ")
       )
     pini implbuf)
;;; output the prologue
;;;
    (add2sbuf_strconst implbuf "/**initial routine prologue**/")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "/* set initial frame marking */")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "((struct melt_callframe_st*)&meltfram__)->mcfr_nbvar = /*minihash*/ -")
    (add2sbuf_longdec implbuf minihash)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "((struct melt_callframe_st*)&meltfram__)->mcfr_forwmarkrout = meltmod__")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf "__forward_or_mark_module_start_frame;")
    (add2sbuf_indentnl implbuf 1)
    (foreach_in_list
     (iprolog)
     (curpair curprol)
       (if (and curprol (not (is_a curprol class_objpurevalue)))
	   (progn
	     (output_c_code curprol declbuf implbuf 1)
	     (add2sbuf_indentnl implbuf 1))
	 ))
    (add2sbuf_strconst implbuf "/**initial routine cdata initializer**/")
    (add2sbuf_indentnl implbuf 0)
;;; output call cdata initializer
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "memset(meltpredefinited, 0, sizeof(meltpredefinited));")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "initialize_module_meltdata_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " (&meltfram__, meltpredefinited);")
    (add2sbuf_indentnl implbuf 1)
;;; output the body
;;;
    (add2sbuf_strconst implbuf "/**initial routine body**/")
    (add2sbuf_indentnl implbuf 0)
    ;; filter out the pure values from the body
    (let ( (rawbody (unsafe_get_field :obrout_body pini)) 
	   (bodylist (make_list discr_list))
	   (chunkbuflist (make_list discr_list))
	   )
      (foreach_in_list
       (rawbody)
       (curpair curbody)
       (if (and curbody (not (is_a curbody class_objpurevalue)))
	   (list_append bodylist curbody)))
      (let ( (bodtup (list_to_multiple bodylist discr_multiple))
	     (chunkbuf ())
	     (:long nbbody (multiple_length bodtup))     
	     (:long chunkcount 0)
	     )
	(foreach_in_multiple
	 (bodtup)
	 (curbody :long bodix)
	 ;; the 128 is the size of each chunk...
	 (if (==i (%iraw bodix 128) 0)
	     (let ( (:long chunkix (+i chunkcount 1))
		    (newchunkbuf (make_strbuf discr_strbuf))
		    )
	       ;;(setq chunkcount (+i chunkcount 1))
	       (increment chunkcount 1)
	       (list_append chunkbuflist newchunkbuf)
	       (setq chunkbuf newchunkbuf)))
	 ;; clear the previous location memoization
	 (unsafe_put_fields prevloc_container :referenced_value ())
	 (unsafe_put_fields previmplbuf_container :referenced_value ())
	 (let ( (curloc (get_field :obi_loc curbody))
		)
	   (if curloc 
	       (output_location curloc chunkbuf 1 "initchunk"))
	   )
	 (output_c_code curbody declbuf chunkbuf 1)
	 (add2sbuf_indentnl chunkbuf 1)
	 (cond ( (>i (strbuf_usedlength chunkbuf) (/iraw (get_int !buffer_limit_cont) 2))
		 (shortbacktrace_dbg "outpucod_initialroutine huge chunkbuf" 10)
		 (debug "outpucod_initialroutine huge chunkbuf=" chunkbuf)
		 (assert_msg "check limited chunkbuf" 
			     (<i (strbuf_usedlength chunkbuf) (get_int !buffer_limit_cont)))))
	 
	 ))
      ;; clear the previous location memoization
      (unsafe_put_fields prevloc_container :referenced_value ())
      (unsafe_put_fields previmplbuf_container :referenced_value ())
      (let ( (chunktup (list_to_multiple chunkbuflist discr_multiple)) 
	     )
	;; declare each chunk and call it notice that the name
	;; frame_melt_start_this_module_st is constructed from name
	;; melt_start_this_module which is built inside our MELT function
	;; compile2obj_initproc.
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_strconst declbuf "struct frame_melt_start_this_module_st;")
	(foreach_in_multiple
	 (chunktup)
	 (curchunk :long chunkix)
	 (add2sbuf_indentnl declbuf 0)
	 (add2sbuf_strconst declbuf "void MELT_MODULE_VISIBILITY meltmod__")
	 (add2sbuf_cident declbuf omodnam)
	 (add2sbuf_strconst declbuf "__initialmeltchunk_")
	 (add2sbuf_longdec declbuf chunkix)
	 (add2sbuf_strconst declbuf " (struct frame_melt_start_this_module_st*, char*);")
	 (add2sbuf_indentnl implbuf 1)
	 (add2sbuf_strconst implbuf "meltmod__")
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "__initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf " (&meltfram__, meltpredefinited);")
	 )
	(add2sbuf_indentnl declbuf 0)
;;; end of implementation
;;;
	(add2sbuf_strconst implbuf ";")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf " goto labend_rout;")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "labend_rout:;")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf " melt_topframe = (struct melt_callframe_st *) meltfram__.mcfr_prev;")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "/* popped initial frame */")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "{ /* clear initial frame & return */")
	(add2sbuf_strconst implbuf " melt_ptr_t retval = ")
	(if oretval 
	    (output_c_code oretval declbuf implbuf 1)
	  (add2sbuf_strconst implbuf "/*noretval*/ NULL"))
	(add2sbuf_strconst implbuf ";")
	(add2sbuf_indentnl implbuf 1)
	(add2sbuf_strconst implbuf " memset((void*) &meltfram__, 0, sizeof(meltfram__));")
	(add2sbuf_indentnl implbuf 1)
	(add2sbuf_strconst implbuf " return retval;}")
	(add2sbuf_indentnl implbuf 1)
	(add2sbuf_strconst implbuf "#undef meltcallcount")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#undef meltfram__")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#undef MELTFRAM_NBVARNUM")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#undef MELTFRAM_NBVARPTR")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "} /* end  */")
	(add2sbuf_indentnl implbuf 0)
	;; output the implementation of each chunk
	(foreach_in_multiple
	 (chunktup)
	 (curchunk :long chunkix)
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "void meltmod__")
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "__initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf " (struct frame_melt_start_this_module_st* meltmeltframptr__, char meltpredefinited[]) {")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#define meltfram__ (*meltmeltframptr__)")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#undef meltcallcount")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#define meltcallcount 0L")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "(void) meltpredefinited;")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_sbuf implbuf curchunk)
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#undef meltfram__")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "} /*end of meltmod__")
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "__initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf "*/")
	 (add2sbuf_indentnl implbuf 0)
	 ;;
	 (cond ( (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
		 (shortbacktrace_dbg "outpucod_initialroutine huge implbuf" 10)
		 (debug "outpucod_initialroutine huge implbuf=" implbuf)
		 (assert_msg "check limited implbuf" 
			     (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))))

	 )
	)
      )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst declbuf "void MELT_MODULE_VISIBILITY meltmod__")
    (add2sbuf_cident declbuf omodnam)
    (add2sbuf_strconst declbuf "__forward_or_mark_module_start_frame (struct melt_callframe_st* fp, int marking);")
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_strconst implbuf "void meltmod__")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf "__forward_or_mark_module_start_frame (struct melt_callframe_st* fp, int marking)")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "int ix=0;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "initial_frame_st* meltframptr_= (initial_frame_st*)fp;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " melt_assertmsg (\"check module frame\", meltframptr_->mcfr_nbvar == /*minihash*/ -")
    (add2sbuf_longdec implbuf minihash)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf 0)
    ;; output the forwarding
    (add2sbuf_strconst implbuf "if (!marking && melt_is_forwarding) {")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "dbgprintf (\"forward_or_mark_module_start_frame_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " forwarding %d pointers in frame %p\", ")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf ", (void*) meltframptr_);")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "for (ix = 0;  ix < ")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf "; ix++)  MELT_FORWARDED(meltframptr_->mcfr_varptr[ix]);")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " return;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "} /*end forwarding*/")
    (add2sbuf_indentnl implbuf 0)
    ;; output the marking
    (add2sbuf_strconst implbuf "dbgprintf (\"forward_or_mark_module_start_frame_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " marking in frame %p\", (void*) meltframptr_);")
    (add2sbuf_indentnl implbuf 0)
    (outpucod_marker pini implbuf)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /* end meltmod__")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf "__forward_or_mark_module_start_frame */") 
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    (assert_msg "check limited declbuf" 
		(<i (strbuf_usedlength declbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_initial_module_routineobj output_c_code outpucod_initialmoduleroutine)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; output extension initial routine
(defun outpucod_initialextensionroutine  (pini declbuf implbuf :long depth)
  (assert_msg "check pini" (is_a pini class_initial_extension_routineobj))
  (debug "outpucod_initialextensionroutine start pini=" pini
	 "\n of discrim " (discrim pini))
  (shortbacktrace_dbg "outpucod_initialextensionroutine" 20)
  (let (
	(oname (get_field :named_name pini))
	(odatup (get_field :oirout_data pini))
	(orfill (get_field :oirout_fill pini))
	(oprolog (get_field :oirout_prolog pini))
	(omodnam (unsafe_get_field :oirout_modulename pini))
	(obody (get_field :obrout_body pini))
	(onbval (get_field :obrout_nbval pini))
	(:long nbval (get_int onbval))
	(:long minihash (+i 1 (%iraw (obj_hash pini) 4096)))
	(oretval (get_field :obrout_retval pini))
	)
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (add2out 
     declbuf 
     ##{ /** declare initial extension running routine $ONAME 
     * of $OMODNAM [outpucod_initialextensionroutine] **/
     MELT_EXTERN melt_ptr_t $ONAME (melt_ptr_t meltarg_curenv_p, meltarg_tuplitval_p) ;
     struct  meltextend_$OMODNAM#_initial_frame_st ;
     void MELT_MODULE_VISIBILITY 
     meltrun_$OMODNAM#_mark_or_forward (struct meltextend_$OMODNAM#_initial_frame_st*, int) ;
     #ifdef MELT_HAVE_DEBUG
     MELT_EXTERN const char meltextend_$OMODNAM#_have_debug_enabled[] ;
     #define melt_have_debug_string meltextend_$OMODNAM#_have_debug_enabled
     #else
     MELT_EXTERN const char meltextend_$OMODNAM#_have_debug_disabled[] ;
     #define melt_have_debug_string meltextend_$OMODNAM#_have_debug_disabled
     #endif /* MELT_HAVE_DEBUG */
     }#)
    (add2sbuf_indentnl declbuf 0)
    (add2out
     implbuf
     ##{ /* implement extension running routine $ONAME 
     of $OMODNAM [outpucod_initialextensionroutine] **/
     #ifdef MELT_HAVE_DEBUG
     const char meltextend_$OMODNAM#_have_debug_enabled[]
     = "MELT running extension $OMODNAM has debug enabled" ;
     #else
     const char meltextend_$OMODNAM#_have_debug_disabled[]
     = "MELT running extension $OMODNAM has debug disabled" ;
     #endif /* MELT_HAVE_DEBUG */
     }#)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2out implbuf ##{
	     /** implement initial extension routine $ONAME 
	     * of $OMODNAM [outpucod_initialextensionroutine] **/
	     melt_ptr_t $ONAME (melt_ptr_t meltarg_curenv_p, meltarg_tuplitval_p) {}#)
    (add2sbuf_strconst implbuf "/* extension routine frame */ typedef ")
    (output_curframe_declstruct pini implbuf)
    (add2out implbuf ##{meltrun_$OMODNAM#_initial_frame_st ;}#
	     )
    (add2sbuf_indentnl implbuf 1)
    (output_curframe_cdat_struct odatup implbuf)
    (add2sbuf_strconst implbuf " *cdat = NULL;")
    (add2sbuf_indentnl implbuf 1)
    ;; generate the initial frame declaration
    (add2out declbuf ##{ /* extension $OMODNAM initial frame */}#)
    (add2sbuf_indentnl implbuf 1)
    (output_curframe_declstruct_init 
     (lambda (rou dsbuf)
       (add2sbuf_indentnl dsbuf 0)
       (add2out dsbuf  ##{ meltrun_$OMODNAM#_initial_frame_st}#))
     pini declbuf)
    ;; generate the prologue
    (debug "outpucod_initialextensionroutine oprolog=" oprolog)
    (add2sbuf_indentnl implbuf 1)
    (add2out implbuf  ##{ /* extension $OMODNAM prologue */}#)
    (foreach_in_list
     (oprolog)
     (curpair curprol)
     (when (and curprol (not (is_a curprol class_objpurevalue)))
       (add2sbuf_indentnl implbuf 1)
       (output_c_code curprol declbuf implbuf 1)))
    ;; generate the fill of the cdata
    (add2sbuf_indentnl implbuf 1)
    (add2out implbuf  ##{ /* extension $OMODNAM cdata fill */}#)
    (output_curframe_cdat_fill odatup implbuf)
    ;; generate the body
    (debug "outpucod_initialextensionroutine obody=" obody)
    (add2sbuf_indentnl implbuf 1)
    (let ( (bodtup
	    (cond 
	     ((is_list obody) (list_to_multiple obody discr_multiple))
	     ((is_multiple obody) obody)
	     (:else
	      (assert_msg "unexpected body"))))
	   (:long nbbody (multiple_length bodtup))
	   )
      (debug "outpucod_initialextensionroutine bodtup=" bodtup)
      (add2out implbuf  ##{ /* extension $OMODNAM body of $NBBODY instructions */}#)
      (foreach_in_multiple
       (bodtup)
       (curbody :long bodix)
       (debug "outpucod_initialextensionroutine curbody=" curbody)
       (when (and curbody (not (is_a curbody class_objpurevalue)))
	 (add2sbuf_indentnl implbuf 1)
	 (add2out implbuf  ##{ /*sideffecting $OMODNAM extension body #$BODIX */}#)
	 (let ( (curloc (get_field :obi_loc curbody))
		)
	   (if curloc 
	       (output_location curloc implbuf 1 "curbody")))
	 (output_c_code curbody declbuf implbuf 1)
	 )
       )
      (add2sbuf_indentnl implbuf 1)
      (add2out implbuf  ##{ /* ending run extension $OMODNAM  */}#)
      (add2out implbuf ##{
#error  run extension $OMODNAM   is incomplete
       } /* end  $ONAME */}#)
      (compile_warning "outpucod_initialextensionroutine is incomplete since generating incomplete code")
      (add2sbuf_indentnl implbuf 0)
      (add2sbuf_indentnl implbuf 0)
      )))
(install_method class_initial_extension_routineobj output_c_code outpucod_initialextensionroutine)





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

;; output code for argument getter
(defun outpucod_getarg (garg declbuf implbuf :long depth)
  (assert_msg "check garg" (is_a garg class_objgetarg))
  (let ( (oloc (unsafe_get_field :obarg_obloc garg)) 
	 (nloc (unsafe_get_field :obi_loc garg))
	 (obind (unsafe_get_field :obarg_bind garg))
	 (:long rkbind (get_int obind))
	 (ctybind (unsafe_get_field :fbind_type obind))
	 )
    (assert_msg "check obind" (is_a obind class_formal_binding))
    (output_location nloc implbuf depth "getarg")
    (assert_msg "check oloc" (is_a oloc class_objlocv))
    (assert_msg "check ctybind" (is_a ctybind class_ctype))
    (if (==i rkbind 0)
	(progn
	  (assert_msg "check ctybind first" (== ctybind ctype_value))
	  (output_c_code oloc declbuf implbuf depth)
	  (add2sbuf_strconst implbuf " = (melt_ptr_t) meltfirstargp_;")
	  (add2sbuf_indentnl implbuf depth)
	  )
      (let (
	    ;; use the ctype_parchar ctype_argfield
	    (parc (unsafe_get_field :ctype_parchar ctybind))
	    (argf (unsafe_get_field :ctype_argfield ctybind)) 
	    )
	(if (not (is_string parc)) 
	    (error_strv oloc "impossible argument ctype" 
			(unsafe_get_field :named_name ctybind)))
	(add2sbuf_strconst implbuf "if (meltxargdescr_[")
	(add2sbuf_longdec implbuf (-i rkbind 1))
	(add2sbuf_strconst implbuf "] != ")
	(add2sbuf_string implbuf parc)
	(add2sbuf_strconst implbuf ") goto lab_endgetargs;")	
	(add2sbuf_indentnl implbuf depth)
	(if (== ctybind ctype_value)
	    (progn
	      (output_c_code oloc declbuf implbuf depth)
	      (add2sbuf_strconst implbuf " = (meltxargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].meltbp_aptr) ? (*(meltxargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].meltbp_aptr)) : NULL;")		
	      (add2sbuf_indentnl implbuf depth)
	      (add2sbuf_strconst implbuf "gcc_assert(melt_discr((melt_ptr_t)(")
	      (output_c_code oloc declbuf implbuf depth)
	      (add2sbuf_strconst implbuf ")) != NULL);")	
	      (add2sbuf_indentnl implbuf depth)
	      )
	  (progn
	    (output_c_code oloc declbuf implbuf depth)
	    (add2sbuf_strconst implbuf " = meltxargtab_[")
	    (add2sbuf_longdec implbuf (-i rkbind 1))
	    (add2sbuf_strconst implbuf "].")
	    (add2sbuf_string implbuf argf)
	    (add2sbuf_strconst implbuf ";")
	    )
	  )
	(add2sbuf_indentnl implbuf depth)
	))
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objgetarg output_c_code outpucod_getarg)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output code for argument getter
(defun outpucod_getargrest (garg declbuf implbuf :long depth)
  (assert_msg "check garg" (is_a garg class_objgetargrest))
  (let ( (oloc (unsafe_get_field :obarg_obloc garg)) 
	 (nloc (unsafe_get_field :obi_loc garg))
	 (obind (unsafe_get_field :obarg_bind garg))
	 (orest (get_field :obarg_rest garg))
	 (:long rkbind (get_int obind))
	 (ctybind (unsafe_get_field :fbind_type obind))
	 (ovariadicindex (variadic_index_idstr orest))
	 (ovariadiclength (variadic_length_idstr orest))
	 )
    (assert_msg "check obind" (is_a obind class_formal_binding))
    (output_location nloc implbuf depth "getarg")
    (assert_msg "check oloc" (is_a oloc class_objlocv))
    (assert_msg "check ctybind" (is_a ctybind class_ctype))
    (if (==i rkbind 0)
	(progn
	  (assert_msg "check ctybind first" (== ctybind ctype_value))
	  (output_c_code oloc declbuf implbuf depth)
	  (add2sbuf_strconst implbuf " = (melt_ptr_t) meltfirstargp_;")
	  (add2sbuf_indentnl implbuf depth)
	  )
      (let (
	    ;; use the ctype_parchar ctype_argfield
	    (parc (unsafe_get_field :ctype_parchar ctybind))
	    (argf (unsafe_get_field :ctype_argfield ctybind)) 
	    )
	(if (not (is_string parc)) 
	    (error_strv oloc "impossible argument ctype" 
			(unsafe_get_field :named_name ctybind)))
	(add2sbuf_strconst implbuf "if (meltxargdescr_[")
	(add2sbuf_longdec implbuf (-i rkbind 1))
	(add2sbuf_strconst implbuf "] != ")
	(add2sbuf_string implbuf parc)
	(add2sbuf_strconst implbuf ") { /*getargrest*/")	
	(add2sbuf_indentnl implbuf (+i 1 depth))
	(add2sbuf_string implbuf ovariadicindex)
	(add2sbuf_strconst implbuf " = ")
	(add2sbuf_string implbuf ovariadiclength)
	(add2sbuf_strconst implbuf ";")
	(add2sbuf_indentnl implbuf (+i 1 depth))
	(add2sbuf_strconst implbuf "goto lab_endgetargs;")
	(add2sbuf_indentnl implbuf depth)	
	(add2sbuf_strconst implbuf "}")
	(add2sbuf_indentnl implbuf depth)
	(add2sbuf_string implbuf ovariadicindex)
	(add2sbuf_strconst implbuf " = ")
	(add2sbuf_longdec implbuf rkbind)
	(add2sbuf_strconst implbuf ";")	
	(add2sbuf_indentnl implbuf depth)
	(if (== ctybind ctype_value)
	    (progn
	      (output_c_code oloc declbuf implbuf depth)
	      (add2sbuf_strconst implbuf " = (meltxargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].meltbp_aptr) ? (*(meltxargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].meltbp_aptr)) : NULL;")		
	      (add2sbuf_indentnl implbuf depth)
	      (add2sbuf_strconst implbuf "gcc_assert(melt_discr((melt_ptr_t)(")
	      (output_c_code oloc declbuf implbuf depth)
	      (add2sbuf_strconst implbuf ")) != NULL);")	
	      (add2sbuf_indentnl implbuf depth)
	      )
	  (progn
	    (output_c_code oloc declbuf implbuf depth)
	    (add2sbuf_strconst implbuf " = meltxargtab_[")
	    (add2sbuf_longdec implbuf (-i rkbind 1))
	    (add2sbuf_strconst implbuf "].")
	    (add2sbuf_string implbuf argf)
	    (add2sbuf_strconst implbuf ";")
	    )
	  )
	(add2sbuf_indentnl implbuf depth)
	))
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objgetargrest output_c_code outpucod_getargrest)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output code for objlocv
(defun outpucod_objlocv (locv declbuf implbuf :long depth)
  (assert_msg "check locv" (is_a locv class_objlocv))
  (let ( 
	(ltyp (unsafe_get_field :obv_type locv))
	(loff (unsafe_get_field :obl_off locv))
	(lcnam (unsafe_get_field :obl_cname locv))
	)
    (cond 
     ( (== ltyp ctype_value)
       (add2sbuf_strconst implbuf "/*_.")
       (add2sbuf_string implbuf lcnam)
       (add2sbuf_strconst implbuf "*/ meltfptr[")
       (add2sbuf_longdec implbuf (get_int loff))
       (add2sbuf_strconst implbuf "]") )
     ( (== ltyp ctype_long)
       (add2sbuf_strconst implbuf "/*_#")
       (add2sbuf_string implbuf lcnam)
       (add2sbuf_strconst implbuf "*/ meltfnum[")
       (add2sbuf_longdec implbuf (get_int loff))
       (add2sbuf_strconst implbuf "]") )
     (:else
      (add2sbuf_strconst implbuf "/*_?*/ meltfram__.")
      (add2sbuf_string implbuf lcnam)))
    )
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objlocv output_c_code outpucod_objlocv)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output code for object closed occurrence
(defun outpucod_objcloccv (occv  declbuf implbuf :long depth)
  (assert_msg "check occv" (is_a occv class_objcloccv))
  (let ( (ooff (unsafe_get_field :obc_off occv))
	 (onam (unsafe_get_field :obc_name occv)) )
    (assert_msg "check valueness of closed occurrence" 
		(== (unsafe_get_field :obv_type occv) ctype_value))
    (add2sbuf_strconst implbuf "(/*~")
    (add2sbuf_string implbuf onam)
    (add2sbuf_strconst implbuf "*/ meltfclos->tabval[")
    (add2sbuf_longdec implbuf (get_int ooff))
    (add2sbuf_strconst implbuf "])")
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objcloccv output_c_code outpucod_objcloccv)


;;;;;;;;;;;;;;;;
;; output code for object const [closed] occurrence
(defun outpucod_objconstv (ocnstv  declbuf implbuf :long depth)
  (assert_msg "check ocnstv" (is_a ocnstv class_objconstv))
  (let ( (ooff (unsafe_get_field :obc_off ocnstv))
	 (onam (unsafe_get_field :obc_name ocnstv)) )
    (assert_msg "check valueness of const occurrence" 
		(== (unsafe_get_field :obv_type ocnstv) ctype_value))
    (add2sbuf_strconst implbuf "(/*!")
    (add2sbuf_string implbuf onam)
    ;; was for debug
    (add2sbuf_strconst implbuf "*/ meltfrout->tabval[")
    (add2sbuf_longdec implbuf (get_int ooff))
    (add2sbuf_strconst implbuf "])")
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objconstv output_c_code outpucod_objconstv)


;; output the code of an instructions list, skipping any pure value
(defun output_code_instructions_list (lis declbuf implbuf boxeddepth)
  (assert_msg "check lis" (is_list_or_null lis))
  (assert_msg "check boxeddepth" (is_integerbox boxeddepth))
  (let ( (:long depth (get_int boxeddepth)) )
    (add2sbuf_indentnl implbuf depth)
    (foreach_in_list
     (lis) 
     (pair cur)
     (cond 
      ( (is_a cur class_objplainblock)
	(add2sbuf_indentnl implbuf depth)
	(let ( (bloc (unsafe_get_field :obi_loc cur))
	       (bodyl (unsafe_get_field :oblo_bodyl cur))
	       (epil (unsafe_get_field :oblo_epil cur))
	       )
	  (if bloc (output_location bloc implbuf depth "quasiblock"))
	  (if bodyl (output_code_instructions_list bodyl declbuf implbuf boxeddepth))
	  (if epil (output_code_instructions_list epil declbuf implbuf boxeddepth))
	  )
	)
      ( (and cur (is_not_a cur class_objpurevalue))
	(add2sbuf_indentnl implbuf depth)
	(output_c_code cur declbuf implbuf depth)
	(add2sbuf_strconst implbuf ";"))
      )					;end cond
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     (assert_msg "check limited declbuf" 
		 (<i (strbuf_usedlength declbuf) (get_int !buffer_limit_cont)))
     ))
  )
  

;;;;;;;;;;;;;;;;
(defun outpucod_objchecksignal (obchi declbuf implbuf :long depth)
  (assert_msg "check ochi" (is_a obchi class_objchecksignal))
  (let ( (oloc (unsafe_get_field :obi_loc obchi))
	 )
    (if oloc (output_location oloc implbuf depth "checksignal"))
    (add2out implbuf " MELT_CHECK_SIGNAL();")
    (add2sbuf_indentnl implbuf depth)
))
(install_method class_objchecksignal output_c_code outpucod_objchecksignal)

;; output code for objanyblock
(defun outpucod_objanyblock (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objanyblock))
  (output_location (unsafe_get_field :obi_loc oblo) implbuf depth "block")
  (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo))
	 (epil (unsafe_get_field :oblo_epil oblo)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (add2sbuf_strconst implbuf "/*anyblock*/{")
    (if (is_list bodyl)
	(output_code_instructions_list bodyl declbuf implbuf boxdepthp1))
    (if (is_list epil)
	(progn
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  (add2sbuf_strconst implbuf "/*epilog*/")
	  (output_code_instructions_list epil declbuf implbuf boxdepthp1)))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objanyblock output_c_code outpucod_objanyblock)

;; output code for objmultiallocblock
(defun outpucod_objmultiallocblock (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objmultiallocblock))
  (let ( (oloc (unsafe_get_field :obi_loc oblo))
	 (oallstruct (unsafe_get_field :omalblo_allstruct oblo))
	 (oname (unsafe_get_field :omalblo_name oblo))
	 (epil (unsafe_get_field :oblo_epil oblo))
	 (bodyl (unsafe_get_field :oblo_bodyl oblo))
	 (:long depthp1 (+i depth 1))
	 (boxdepthp1 (make_integerbox discr_integer depthp1))
	 (onameptr (let ( (ptrbuf (make_strbuf discr_strbuf)) )
		     (add2sbuf_string ptrbuf oname)
		     (add2sbuf_strconst ptrbuf "_ptr")
		     (strbuf2string discr_verbatim_string ptrbuf)))
	 )
    (output_location oloc implbuf depth "blockmultialloc")
    (assert_msg "check oallstruct" (is_multiple_or_null oallstruct))
    (add2sbuf_strconst implbuf "/*multiallocblock*/{")
    (add2sbuf_indentnl implbuf depthp1)
    (add2sbuf_strconst implbuf "struct ")
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_st {")
    (foreach_in_multiple
     (oallstruct)
     (curstru :long strix)
     (assert_msg "check curstru" (is_a curstru class_objinitelem))
     (add2sbuf_indentnl implbuf depthp1)
     (output_c_declinit curstru implbuf)
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (add2sbuf_strconst implbuf " long ")
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_endgap; } *")
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_ptr = 0;")
    (add2sbuf_indentnl implbuf depthp1)
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_ptr = (struct ")
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_st *) meltgc_allocate (sizeof (struct ")
    (add2sbuf_string implbuf oname)
    (add2sbuf_strconst implbuf "_st), 0);")
    (add2sbuf_indentnl implbuf depthp1)   
    ;;
    (output_location oloc implbuf depth "blockmultialloc.initfill")
    (foreach_in_multiple
     (oallstruct)
     (curstru :long strix)
     (output_c_initial_fill curstru implbuf onameptr depthp1)
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     (add2sbuf_indentnl implbuf depthp1)   
     )
    ;;
    (if (is_list bodyl)
	(output_code_instructions_list bodyl declbuf implbuf boxdepthp1))
    ;;
    (if (is_list epil)
	(progn
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  (add2sbuf_strconst implbuf "/*epilog*/")
	  (output_code_instructions_list epil declbuf implbuf boxdepthp1)))
					;(assert_msg "@$@unimplemented outpucod_objmultiallocblock" ())
    (add2sbuf_strconst implbuf "} /*end multiallocblock*/")
    (add2sbuf_indentnl implbuf depth)
    )
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objmultiallocblock output_c_code outpucod_objmultiallocblock)

;; output code for objciterblock
(defun outpucod_objciterblock (obcit  declbuf implbuf :long depth)
  (assert_msg "check obcit" (is_a obcit class_objciterblock))
  (let ( (oloc (unsafe_get_field :obi_loc obcit))
	 (bodyl (unsafe_get_field :oblo_bodyl obcit))
	 (epil (unsafe_get_field :oblo_epil obcit)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 (obefore (unsafe_get_field :obciter_before obcit))
	 (oafter (unsafe_get_field :obciter_after obcit))
	 (citer (unsafe_get_field :obciter_citer obcit))
	 )
    (assert_msg "check citer" (is_a citer class_citerator))
    (output_location oloc "citerblock")
    (add2sbuf_strconst implbuf "/*citerblock ")
    (add2sbuf_ccomstring implbuf (unsafe_get_field :named_name citer))
    (add2sbuf_strconst implbuf "*/ {")
    (add2sbuf_indentnl implbuf depth)
    (output_location oloc "citerbefore")
    (foreach_in_multiple 
     (obefore)
     (obef :long ix)
     (output_c_code obef declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (add2sbuf_indentnl implbuf depth)
    (output_location oloc "citerbody")
    (if (is_list bodyl)
	(output_code_instructions_list bodyl declbuf implbuf boxdepthp1))
    (add2sbuf_indentnl implbuf depth)
    (output_location oloc "citerafter")
    (foreach_in_multiple
     (oafter)
     (oaft :long ix)
     (output_c_code oaft declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (add2sbuf_indentnl implbuf depth)
    (output_location oloc "citerepil")
    (if (is_list epil)
	(progn
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  (add2sbuf_strconst implbuf "/*citerepilog*/")
	  (output_code_instructions_list epil declbuf implbuf boxdepthp1)))
    (add2sbuf_strconst implbuf "} /*endciterblock ")
    (add2sbuf_ccomstring implbuf (unsafe_get_field :named_name citer))
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf depth)
    )
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objciterblock output_c_code outpucod_objciterblock)

;;;;;;;;;;;;;;;;
(defun outpucod_objcommentinstr (obci declbuf implbuf :long depth)
  (assert_msg "check obci" (is_a obci class_objcommentinstr))
  (let ( (oloc (unsafe_get_field :obi_loc obci))
	 (coms (unsafe_get_field :obci_comment obci))
	 (comstr (let ( (sbu (make_strbuf discr_strbuf)) )
		   (add2sbuf_ccomstring sbu coms)
		   (strbuf2string discr_string sbu)
		   ))
	 )
    (output_location oloc implbuf depth "comment")
    (add2sbuf_strconst implbuf "/**COMMENT: ")
    (add2sbuf_string implbuf comstr)
    (add2sbuf_strconst implbuf " **/;")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objcommentinstr output_c_code outpucod_objcommentinstr)

;;;;;;;;;;;;;;;;
;; output code for objcommentedblock
(defun outpucod_objcommentedblock (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objcommentedblock))
  (output_location (unsafe_get_field :obi_loc oblo) implbuf depth "block")
  (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo))
	 (epil (unsafe_get_field :oblo_epil oblo)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 (coms (unsafe_get_field :ocomblo_comment oblo))
	 (comstr (let ( (sbu (make_strbuf discr_strbuf)) )
		   (add2sbuf_ccomstring sbu coms)
		   (strbuf2string discr_string sbu)
		   ))
	 )
    (add2sbuf_strconst implbuf "/*com.block:")
    (add2sbuf_string implbuf comstr)
    (add2sbuf_strconst implbuf "*/{")
    (if (is_list bodyl)
	(output_code_instructions_list bodyl declbuf implbuf boxdepthp1))
    (if (is_list epil)
	(progn
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  (add2sbuf_strconst implbuf "/*comp.epilog:")
	  (add2sbuf_string implbuf comstr)
	  (add2sbuf_strconst implbuf "*/")
	  (output_code_instructions_list epil declbuf implbuf boxdepthp1)))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_strconst implbuf "/*com.end block:")
    (add2sbuf_string implbuf comstr)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objcommentedblock output_c_code outpucod_objcommentedblock)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; output code for label instr

(defun outpucod_objlabelinstr (oblab declbuf implbuf :long depth)
  (assert_msg "check oblab" (is_a oblab class_objlabelinstr))
  (add2sbuf_indentnl implbuf depth)
  (add2sbuf_strconst implbuf "/*objlabel*/ ")
  (add2sbuf_string implbuf (unsafe_get_field :oblab_prefix oblab))
  (let ( (obrank (unsafe_get_field :oblab_rank oblab)) )
    (if obrank
	(add2sbuf_longdec implbuf (get_int (unsafe_get_field :oblab_rank oblab)))))
  (add2sbuf_strconst implbuf ": ;")
  (add2sbuf_indentnl implbuf depth)
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  (output_location (unsafe_get_field :obi_loc oblab) implbuf depth "objlabel")
  )
(install_method class_objlabelinstr output_c_code outpucod_objlabelinstr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; output code for goto instr

(defun outpucod_objgotoinstr (obgoto declbuf implbuf :long depth)
  (assert_msg "check obgoto" (is_a obgoto class_objgotoinstr))
  (output_location (unsafe_get_field :obi_loc obgoto) implbuf depth "objgoto")
  (add2sbuf_strconst implbuf "/*objgoto*/ goto ")
  (add2sbuf_string implbuf (unsafe_get_field :obgoto_prefix obgoto))
  (let ( (obrank (unsafe_get_field :obgoto_rank obgoto)) )
    (if obrank
	(add2sbuf_longdec implbuf (get_int obrank))))
  (add2sbuf_strconst implbuf ";")
  (add2sbuf_indentnl implbuf depth)
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objgotoinstr output_c_code outpucod_objgotoinstr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; add a cname for a cloned identifier into a buffer
(defun add2sbuf_clonsym (sbuf csy)
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (assert_msg "check csy" (is_a csy class_cloned_symbol))
  (let ( (cnam (unsafe_get_field :named_name csy))
	 (:long rk (get_int (unsafe_get_field :csym_urank csy))) )
    (add2sbuf_cident sbuf cnam)
    (add2sbuf_strconst sbuf "_")
    (add2sbuf_longdec sbuf rk)
    (assert_msg "check limited sbuf" 
		(<i (strbuf_usedlength sbuf) (get_int !buffer_limit_cont)))
    ))

;;; output code for objloop
(defun outpucod_objloop (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objloop))
  (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo))
	 (epil (unsafe_get_field :oblo_epil oblo)) 
	 (lab (unsafe_get_field :obloop_label oblo))
	 (oloc (unsafe_get_field :obi_loc oblo))
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (assert_msg "check lab" (is_a lab class_cloned_symbol))
    (output_location oloc implbuf depth "loop")
    (add2sbuf_strconst implbuf "/*loop*/{ labloop_")
    (add2sbuf_clonsym implbuf lab)
    (add2sbuf_strconst implbuf ":;")
    (if (is_list bodyl)
	(progn
	  (output_location oloc implbuf depth "loopbody")
	  (add2sbuf_indentnl implbuf (+i depth 1))
	  (list_every
	   bodyl
	   (lambda (curbody)
	     (let ( (:long depthp1 (get_int boxdepthp1)) )
	       (if (and curbody (not (is_a curbody class_objpurevalue)))
		   (output_c_code curbody declbuf implbuf depthp1))
	       (add2sbuf_strconst implbuf ";")
	       (add2sbuf_indentnl implbuf depthp1))))))
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf " goto labloop_")
    (add2sbuf_clonsym implbuf lab)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf " labexit_")
    (add2sbuf_clonsym implbuf lab)
    (add2sbuf_strconst implbuf ":;")
    (if (is_list epil)
	(progn
	  (output_location oloc implbuf depth "loopepilog")
	  (add2sbuf_strconst implbuf "/*loopepilog*/")
	  (add2sbuf_indentnl implbuf (+i depth 1))
	  (list_every
	   epil
	   (lambda (curepil)
	     (let ( (:long depthp1 (get_int boxdepthp1)) )
	       (if (and curepil (not (is_a curepil class_objpurevalue)))
		   (output_c_code curepil declbuf implbuf depthp1))
	       (add2sbuf_strconst implbuf ";")
	       (assert_msg "check limited implbuf" 
			   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	       (add2sbuf_indentnl implbuf depthp1))))))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objloop output_c_code outpucod_objloop)


;;; output code for objexit
(defun outpucod_objexit (obxi declbuf implbuf :long depth)
  (assert_msg "check obxi" (is_a obxi class_objexit))
  (let ( (olab (unsafe_get_field :obexit_label obxi))
	 (loc (unsafe_get_field :obi_loc obxi))
	 )
    (assert_msg "check olab" (is_a olab class_cloned_symbol))
    (output_location loc implbuf depth "exit")
    (add2sbuf_strconst implbuf "/*exit*/{")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf " goto labexit_")
    (add2sbuf_clonsym implbuf olab)	
    (add2sbuf_strconst implbuf ";}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))    
    ))
(install_method class_objexit output_c_code outpucod_objexit)


;;; output code for objagain
(defun outpucod_objagain (obag declbuf implbuf :long depth)
  (assert_msg "check obag" (is_a obag class_objagain))
  (let ( (olab (unsafe_get_field :obagain_label obag))
	 (loc (unsafe_get_field :obi_loc obag))
	 )
    (assert_msg "check olab" (is_a olab class_cloned_symbol))
    (output_location loc implbuf depth "again")
    (add2sbuf_strconst implbuf "/*again*/{")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf " goto labloop_")
    (add2sbuf_clonsym implbuf olab)	
    (add2sbuf_strconst implbuf ";}")
    (add2sbuf_indentnl implbuf depth) 
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))   
    ))
(install_method class_objagain output_c_code outpucod_objagain)

;;; output code for objcompute
(defun outpucod_objcompute (obcomp declbuf implbuf :long depth)
  (assert_msg "check obcomp" (is_a obcomp class_objcompute))
  (let ( (cdest (unsafe_get_field :obdi_destlist obcomp)) ; destination list
	 (cloc (unsafe_get_field :obi_loc obcomp))
	 (cexp (unsafe_get_field :obcpt_expr obcomp)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (output_location cloc implbuf depth "compute")
    (if (is_list cdest)
	(list_every
	 cdest
	 (lambda (destcur) 
	   (output_c_code destcur declbuf implbuf (get_int boxdepthp1))
	   (add2sbuf_strconst implbuf " = ")
	   ())))
    (cond ((is_list cexp)
	   (if (>i (list_length cexp) 2)
	       (add2sbuf_indentnl implbuf (+i 1 depth)))
	   (list_every
	    cexp 
	    (lambda (expcur) 
	      (output_c_code expcur declbuf implbuf (get_int boxdepthp1))
	      (assert_msg "check limited implbuf" 
			  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	      )))
	  ((is_multiple cexp)
	   (if (>i (multiple_length cexp) 2)
	       (add2sbuf_indentnl implbuf (+i 1 depth)))
	   (multiple_every
	    cexp
	    (lambda (expcur) 
	      (output_c_code expcur declbuf implbuf (get_int boxdepthp1))
	      (assert_msg "check limited implbuf" 
			  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	      )))
	  (:else
	   (output_c_code cexp declbuf implbuf (+i depth 1))
	   ))
    (add2sbuf_strconst implbuf ";")
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objcompute output_c_code outpucod_objcompute)


;; output a conditional
(defun outpucod_objcond (ocond declbuf implbuf :long depth)
  (assert_msg "check ocond" (is_a ocond class_objcond))
  (let ( (cloc (unsafe_get_field :obi_loc ocond))
	 (ctest (unsafe_get_field :obcond_test ocond))
	 (cthen (unsafe_get_field :obcond_then ocond))
	 (celse (unsafe_get_field :obcond_else ocond)) 
	 )
    (assert_msg "check ctest" (notnull ctest))
    (output_location cloc implbuf depth "cond")
    (add2sbuf_strconst implbuf "/*cond*/ if (")
    (output_c_code ctest declbuf implbuf (+i depth 1))
    (add2sbuf_strconst implbuf ") /*then*/ {")
    (add2sbuf_indentnl implbuf depth)
    (if (and cthen (not (is_a cthen class_objpurevalue)))
	(progn
	  (output_location cloc implbuf depth "cond.then")
	  (output_c_code cthen declbuf implbuf (+i depth 1))
	  (add2sbuf_strconst implbuf ";")
	  (add2sbuf_indentnl implbuf depth)
	  )
      )
    (if (and celse (not (is_a celse class_objpurevalue)))
	(progn
	  (add2sbuf_strconst implbuf "} else {")
	  (output_location cloc implbuf depth "cond.else")
	  (add2sbuf_indentnl implbuf (+i depth 1))
	  (output_c_code celse declbuf implbuf (+i depth 1))
	  (add2sbuf_strconst implbuf ";")
	  (add2sbuf_indentnl implbuf (+i depth 1))
	  (add2sbuf_strconst implbuf "}") ;
	  )
      (add2sbuf_strconst implbuf "} /*noelse*/")
      )
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ) 
  )
(install_method class_objcond output_c_code outpucod_objcond)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; output a cppif
(defun outpucod_objcppif (opif declbuf implbuf :long depth)
  (assert_msg "check opif" (is_a opif class_objcppif))
  (let ( (cloc (unsafe_get_field :obi_loc opif))
	 (ccond (unsafe_get_field :obifp_cond opif))
	 (cthen (unsafe_get_field :obifp_then opif))
	 (celse (unsafe_get_field :obifp_else opif))
	 (:long depthp1 (+i 1 depth))
	 )
    (assert_msg "check ccond" (is_string ccond))
    (output_raw_location cloc implbuf depth "cppif")
    (add2sbuf_strconst implbuf "#if ")
    (add2sbuf_string implbuf ccond)
    (add2sbuf_indentnl implbuf depthp1)
    (output_location cloc implbuf depth "cppif.then")
    (output_c_code cthen declbuf implbuf depthp1)
    (add2sbuf_indentnl implbuf depthp1)
    (add2sbuf_strconst implbuf "#else /*")
    (add2sbuf_string implbuf ccond)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf depthp1)
    (output_location cloc implbuf depth "cppif.else")
    (output_c_code celse declbuf implbuf depthp1)
    (add2sbuf_indentnl implbuf depthp1)
    (add2sbuf_strconst implbuf "#endif /*")
    (add2sbuf_string implbuf ccond)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf depthp1)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objcppif output_c_code outpucod_objcppif)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun outpucod_objinternsymbol (oisy declbuf implbuf :long depth)
  (assert_msg "check oisy" (is_a oisy class_objinternsymbol))
  (let ( (cloc (unsafe_get_field :obi_loc oisy))
	 (oiobj (unsafe_get_field :obintern_iobj oisy))
	 (oidat (unsafe_get_field :oie_data oiobj)) 
	 (oilocv (unsafe_get_field :oie_locvar oiobj)) 
	 )
    (assert_msg "check oiobj" (is_a oiobj class_objinitobject))
    (assert_msg "check oidat" (is_a oidat class_nrep_datasymbol))
    (let ( (nsy (unsafe_get_field :ndsy_namestr oidat)) )
      (output_location (if cloc cloc (unsafe_get_field :nrep_loc oidat)) implbuf 1 "internsymbol")
      (add2sbuf_strconst implbuf "/*internsym:")
      (add2sbuf_string implbuf nsy)
      (add2sbuf_strconst implbuf "*/")
      (add2sbuf_indentnl implbuf depth)
      (add2sbuf_strconst implbuf "(void) meltgc_intern_symbol((melt_ptr_t)(")
      (output_c_code oilocv declbuf implbuf depth)
      (add2sbuf_strconst implbuf "));")
      (add2sbuf_indentnl implbuf depth))
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objinternsymbol output_c_code outpucod_objinternsymbol)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun outpucod_objinternkeyword (oikw declbuf implbuf :long depth)
  (assert_msg "check oikw" (is_a oikw class_objinternkeyword))
  (let ( (cloc (unsafe_get_field :obi_loc oikw))
	 (oiobj (unsafe_get_field :obintern_iobj oikw))
	 (oidat (unsafe_get_field :oie_data oiobj)) 
	 (oilocv (unsafe_get_field :oie_locvar oiobj)) 
	 )
    (assert_msg "check oidat" (is_a oidat class_nrep_datakeyword))
    (let ( (nsy (unsafe_get_field :ndsy_namestr oidat)) )
      (output_location (if cloc cloc (unsafe_get_field :nrep_loc oidat)) implbuf depth "internkeyword")
      (add2sbuf_strconst implbuf "/*internkeyw:")
      (add2sbuf_string implbuf nsy)
      (add2sbuf_strconst implbuf "*/")
      (add2sbuf_indentnl implbuf depth)
      (add2sbuf_strconst implbuf "(void) meltgc_intern_keyword((melt_ptr_t)(")
      (output_c_code oilocv declbuf implbuf depth)
      (add2sbuf_strconst implbuf "));")
      (add2sbuf_indentnl implbuf depth))
    (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objinternkeyword output_c_code outpucod_objinternkeyword)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun outpucod_objgetnamedsymbol (ogsy declbuf implbuf :long depth)
  (assert_msg "check ogsy" (is_a ogsy class_objgetnamedsymbol))
  (let ( (cloc (unsafe_get_field :obi_loc ogsy))
	 (oiobj (unsafe_get_field :obgnamed_iobj ogsy)) 
	 (ogdat (unsafe_get_field :oie_data oiobj))
	 (oilocv (unsafe_get_field :oie_locvar oiobj))
	 )
    (assert_msg "check oiobj" (is_a oiobj class_objinitobject))
    (assert_msg "check ogdat" (is_a ogdat class_nrep_datasymbol))
    (let ( (nsy (unsafe_get_field :ndsy_namestr ogdat)) 
	   )
      (output_location (if cloc cloc (unsafe_get_field :nrep_loc ogdat)) implbuf depth "getnamedsymbol")
      (add2sbuf_strconst implbuf "/*getnamedsym:")
      (add2sbuf_string implbuf nsy)
      (add2sbuf_strconst implbuf "*/")
      (add2sbuf_indentnl implbuf depth)
      (add2sbuf_strconst implbuf "{ melt_ptr_t sy_")
      (add2sbuf_cident implbuf nsy)
      (add2sbuf_strconst implbuf " = meltgc_named_symbol(\"")
      (add2sbuf_string implbuf nsy)
      (add2sbuf_strconst implbuf "\", MELT_GET);")
      (add2sbuf_indentnl implbuf (+i depth 1))
      (add2sbuf_strconst implbuf "if (sy_")
      (add2sbuf_cident implbuf nsy)
      (add2sbuf_strconst implbuf " && NULL == ")
      (output_c_code oilocv declbuf implbuf (+i depth 1))
      (add2sbuf_strconst implbuf ")")
      (add2sbuf_indentnl implbuf (+i depth 1))
      (output_c_code oilocv declbuf implbuf (+i depth 1))
      (add2sbuf_strconst implbuf " = (melt_ptr_t) sy_")
      (add2sbuf_cident implbuf nsy)
      (add2sbuf_strconst implbuf "; }")
      (add2sbuf_indentnl implbuf depth)
      (assert_msg "check limited implbuf" 
		  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
      )))
(install_method class_objgetnamedsymbol output_c_code outpucod_objgetnamedsymbol)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun outpucod_objgetnamedkeyword (ogkw declbuf implbuf :long depth)
  (assert_msg "check ogkw" (is_a ogkw class_objgetnamedkeyword))
  (let ( (cloc (unsafe_get_field :obi_loc ogkw))
	 (oiobj (unsafe_get_field :obgnamed_iobj ogkw)) 
	 (ogdat (unsafe_get_field :oie_data oiobj))
	 (oilocv (unsafe_get_field :oie_locvar oiobj))
	 )
    (assert_msg "check oiobj" (is_a oiobj class_objinitobject))
    (assert_msg "check ogdat" (is_a ogdat class_nrep_datakeyword))
    (let ( (nkw (unsafe_get_field :ndsy_namestr ogdat)) )
      (output_location (if cloc cloc (unsafe_get_field :nrep_loc ogdat)) implbuf depth "getnamedkeyword")
      (add2sbuf_strconst implbuf "/*getnamedkeyw:")
      (add2sbuf_string implbuf nkw)
      (add2sbuf_strconst implbuf "*/")
      (add2sbuf_indentnl implbuf depth)
      (add2sbuf_strconst implbuf "{ melt_ptr_t kw_")
      (add2sbuf_cident implbuf nkw)
      (add2sbuf_strconst implbuf " = meltgc_named_keyword(\"")
      (add2sbuf_string implbuf nkw)
      (add2sbuf_strconst implbuf "\", MELT_GET);")
      (add2sbuf_indentnl implbuf (+i depth 1))
      (add2sbuf_strconst implbuf "if (kw_")
      (add2sbuf_cident implbuf nkw)
      (add2sbuf_strconst implbuf ") ")
      (output_c_code oilocv declbuf implbuf (+i depth 1))
      (add2sbuf_strconst implbuf " = (melt_ptr_t) kw_")
      (add2sbuf_cident implbuf nkw)
      (add2sbuf_strconst implbuf "; }")
      (add2sbuf_indentnl implbuf depth)
      (assert_msg "check limited implbuf" 
		  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
      )))
(install_method class_objgetnamedkeyword output_c_code outpucod_objgetnamedkeyword)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output an application
(defun outpucod_objapply (oapp declbuf implbuf :long depth)
  (assert_msg "check oapp" (is_a oapp class_objapply))
  (let (
	(aloc (unsafe_get_field :obi_loc oapp))
	(adest (unsafe_get_field :obdi_destlist oapp))
	(oclos (unsafe_get_field :obapp_clos oapp))
	(oargs (unsafe_get_field :obapp_args oapp))
	(:long nbarg (multiple_length oargs))
	(paramdesclist (make_list discr_list))
	(boxdepthp1 (make_integerbox discr_integer (+i 1 depth)))
	)
    (output_location aloc implbuf depth "apply")
    (add2sbuf_strconst implbuf "/*apply*/{")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (if (>i nbarg 1)
	(progn
	  (add2sbuf_strconst implbuf "union meltparam_un argtab[")
	  (add2sbuf_longdec implbuf (-i nbarg 1))
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ;; output the initialization of argtab and fill the paramdesclist
	  (foreach_in_multiple
	   (oargs)
	   (curarg :long curank)
	   (assert_msg "outputcod_objapply check curarg not objinstr" (not (is_a curarg class_objinstr)))
	   (if (>i curank 0)
	       (let ( (curctyp (get_ctype curarg ())) )
		 (assert_msg "check curctyp" (is_a curctyp class_ctype))
		 (output_location aloc implbuf (get_int boxdepthp1) "apply.arg")
		 (add2sbuf_strconst implbuf "argtab[")
		 (add2sbuf_longdec implbuf  (-i curank 1))
		 (add2sbuf_strconst implbuf "].")
		 (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp))
		 (cond ( (null curarg)
			 (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL")) 
		       ( (is_a curarg class_objnil)
			 (add2sbuf_strconst implbuf "meltbp_aptr = /*nil*/(melt_ptr_t*)NULL"))
		       ( (== curctyp ctype_value)
			 (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
			 (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
			 )
		       (:else 
			(add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp))
			(add2sbuf_strconst implbuf " = ")
			(output_c_code curarg declbuf implbuf (get_int boxdepthp1))
			))
		 (add2sbuf_strconst implbuf ";")
		 (add2sbuf_indentnl implbuf (get_int boxdepthp1))
		 ))
	   (assert_msg "check limited implbuf" 
		       (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	   )
	  ))
;;; output the destination(s)
    (list_every 
     adest
     (lambda (curdest) 
       (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
       (assert_msg "check limited implbuf" 
		   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
       (add2sbuf_strconst implbuf " = ")))
    ;; output the apply and the closure
    (add2sbuf_strconst implbuf " melt_apply ((meltclosure_ptr_t)(")
    (output_c_code oclos declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), (melt_ptr_t)(")
    ;; output the first argument
    (let ( (firstarg (multiple_nth oargs 0)) )
      (output_c_code firstarg declbuf implbuf (+i 1 depth))
      )
    (add2sbuf_strconst implbuf "), (")
    ;; output the argdescr string
    (list_every
     paramdesclist
     (lambda (pard)
       (add2sbuf_string implbuf pard)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    ;; output the argtab (or null if none)
    (if (>i nbarg 1)
	(add2sbuf_strconst implbuf "argtab,")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0,"))
    ;; no extra results
    (add2sbuf_strconst implbuf " \"\", (union meltparam_un*)0")
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objapply output_c_code outpucod_objapply)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output a message send
(defun outpucod_objmsend (omsend declbuf implbuf :long depth)
  (assert_msg "check omsend" (is_a omsend class_objmsend))
  (let ( (oloc (unsafe_get_field :obi_loc omsend))
	 (odest (unsafe_get_field :obdi_destlist omsend))
	 (osel (unsafe_get_field :obmsnd_sel omsend))
	 (orecv (unsafe_get_field :obmsnd_recv omsend))
	 (oargs (unsafe_get_field :obmsnd_args omsend))
	 (:long nbarg (multiple_length oargs))
	 (paramdesclist (make_list discr_list))
	 (boxdepthp1 (make_integerbox discr_integer (+i 1 depth)))
	 )
    (output_location oloc implbuf depth "msend")
    (add2sbuf_strconst implbuf "/*msend*/{")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (if (>i nbarg 0)
	;; the code below is very similar to code inside
	;; outpucod_objapply except that we do not shift arguments by
	;; one
	(progn
	  (add2sbuf_strconst implbuf "union meltparam_un argtab[")
	  (add2sbuf_longdec implbuf nbarg)
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ;; output the initialization of argtab and fill the paramdesclist
	  (foreach_in_multiple
	   (oargs)
	   (curarg :long curank)
	   (let ( (curctyp (get_ctype curarg ())) )
	     (assert_msg "check curctyp" (is_a curctyp class_ctype))
	     (output_location oloc implbuf (get_int boxdepthp1) "ojbmsend.arg")
	     (add2sbuf_strconst implbuf "argtab[")
	     (add2sbuf_longdec implbuf  curank)
	     (add2sbuf_strconst implbuf "].")
	     (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp))
	     (cond ( (null curarg)
		     (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL")
		     ) 
		   ( (is_a curarg class_objnil)
		     (add2sbuf_strconst implbuf "meltbp_aptr = /*nil*/(melt_ptr_t*)NULL")
		     )
		   ( (== curctyp ctype_value)
		     (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
		     (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		     )
		   (:else
		    (assert_msg "check curarg is not multiple" (not (is_multiple curarg)))
		    (add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp))
		    (add2sbuf_strconst implbuf " = ")
		    (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		    ))
	     (add2sbuf_strconst implbuf ";")
	     (assert_msg "check limited implbuf" 
			 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	     (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	     ))
	  ))
;;; output the destination(s)
    (foreach_in_list
     (odest)
     (curpair curdest) 
     (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     (add2sbuf_strconst implbuf " = "))
    ;;
    (assert_msg "check orecv object" (is_object orecv))
    ;;
    (add2sbuf_strconst implbuf "meltgc_send((melt_ptr_t)(")
    (output_c_code orecv declbuf implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "), (melt_ptr_t)(")
    (output_c_code osel declbuf implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "), (")
    ;; output the argdescr string
    (list_every
     paramdesclist
     (lambda (pard)
       (add2sbuf_string implbuf pard)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    (if (>i nbarg 0)
	(add2sbuf_strconst implbuf "argtab,")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0,"))
    ;; no extra results
    (add2sbuf_strconst implbuf " \"\", (union meltparam_un*)0")
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objmsend output_c_code outpucod_objmsend)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output a multiresult application

(defun outpucod_objmultiapply (oapp declbuf implbuf :long depth)
  (assert_msg "check oapp" (is_a oapp class_objmultiapply))
  (let (
	(aloc (unsafe_get_field :obi_loc oapp))
	(adest (unsafe_get_field :obdi_destlist oapp))
	(oclos (unsafe_get_field :obapp_clos oapp))
	(oargs (unsafe_get_field :obapp_args oapp))
	(oxres (unsafe_get_field :obmultapp_xres oapp))
	(:long nbarg (multiple_length oargs))
	(:long nbxres (multiple_length oxres))
	(paramdesclist (make_list discr_list))
	(resdesclist (make_list discr_list))
	(boxdepthp1 (make_integerbox discr_integer (+i 1 depth)))
	)
    (assert_msg "check oargs" (is_multiple_or_null oargs))
    (assert_msg "check oxres" (is_multiple_or_null oxres))
    (output_location aloc implbuf depth "multiapply")
    (add2sbuf_strconst implbuf "/*multiapply ")
    (add2sbuf_longdec implbuf nbarg)
    (add2sbuf_strconst implbuf "args, ")
    (add2sbuf_longdec implbuf nbxres)
    (add2sbuf_strconst implbuf "x.res*/ ")
    (add2sbuf_strconst implbuf "{")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (if (>i nbarg 1)
	(progn
	  (add2sbuf_strconst implbuf "union meltparam_un argtab[")
	  (add2sbuf_longdec implbuf (-i nbarg 1))
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ))
    (if (>i nbxres 0)
	(progn
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  (add2sbuf_strconst implbuf "union meltparam_un restab[")
	  (add2sbuf_longdec implbuf nbxres)
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ))
    (if (>i nbxres 0)
	(progn
	  (add2sbuf_strconst implbuf "memset(&restab, 0, sizeof(restab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ;; fill the resdesclist
	  (multiple_every 
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curctyp (get_ctype cures ())) )
	       (list_append resdesclist (unsafe_get_field :ctype_parstring curctyp)))))))
    (if (>i nbarg 1)
	(progn
	  (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ;; output the initialization of argtab and fill the paramdesclist
	  (foreach_in_multiple
	   (oargs)
	   (curarg :long curank)
	   (if (>i curank 0)
	       (let ( (curctyp (get_ctype curarg ())) )
		 (assert_msg "check curctyp" (is_a curctyp class_ctype))
		 (output_location aloc implbuf (get_int boxdepthp1) "multiapply.arg")
		 (add2sbuf_strconst implbuf "argtab[")
		 (add2sbuf_longdec implbuf  (-i curank 1))
		 (add2sbuf_strconst implbuf "].")
		 (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp))
		 (cond
		  ( (null curarg)
		    (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL"))
		  ( (== curctyp ctype_value)
		    (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
		    (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		    )
		  (:else
		   (add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp))
		   (add2sbuf_strconst implbuf " = ")
		   (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		   ))
		 (add2sbuf_strconst implbuf ";")
		 ))
	   (assert_msg "check limited implbuf" 
		       (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	   )
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  ))
    ;; output the initialization of restab
    (if (>i nbxres 0)
	(progn
	  (multiple_every
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curestyp (get_ctype cures ())) )
	       (assert_msg "check curestyp" (is_a curestyp class_ctype))
	       (output_location aloc implbuf (get_int boxdepthp1) "multiapply.xres")
	       (add2sbuf_strconst implbuf "restab[")
	       (add2sbuf_longdec implbuf  curank)
	       (add2sbuf_strconst implbuf "].")
	       (cond
		( (null cures)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL"))
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
		  (output_c_code cures declbuf implbuf (get_int boxdepthp1))
		  )
		(:else
		 (add2sbuf_string implbuf (unsafe_get_field :ctype_resfield curestyp))
		 (add2sbuf_strconst implbuf " =  & ")
		 (output_c_code cures declbuf implbuf (get_int boxdepthp1))
		 ))
	       (add2sbuf_strconst implbuf ";")
	       (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	       )
	     ))
	  ))
    (output_location aloc implbuf (get_int boxdepthp1) "multiapply.appl")
;;; output the destination(s)
    (list_every
     adest
     (lambda (curdest) 
       (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
       (add2sbuf_strconst implbuf " = ")))
    ;; output the apply and the closure
    (add2sbuf_strconst implbuf " melt_apply ((meltclosure_ptr_t)(")
    (output_c_code oclos declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), (melt_ptr_t)(")
    ;; output the first argument
    (let ( (firstarg (multiple_nth oargs 0)) )
      (output_c_code firstarg declbuf implbuf (+i 1 depth))
      )
    (add2sbuf_strconst implbuf "), (")
    ;; output the argdescr string
    (list_every 
     paramdesclist
     (lambda (pard)
       (add2sbuf_string implbuf pard)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    ;; output the argtab (or null if none)
    (if (>i nbarg 1)
	(add2sbuf_strconst implbuf "argtab, (")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0, ("))
    ;; output the resdescr string
    (list_every
     resdesclist
     (lambda (resd)
       (add2sbuf_string implbuf resd)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    ;; output the extra results
    (if (>i nbxres 0)
	(add2sbuf_strconst implbuf "restab")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0"))
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))

(install_method class_objmultiapply output_c_code outpucod_objmultiapply)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output a multiresult message send
(defun outpucod_objmultimsend (omsnd  declbuf implbuf :long depth)
  (assert_msg "check omsnd" (is_a omsnd class_objmultimsend))
  (let ( (oloc (unsafe_get_field :obi_loc omsnd))
	 (odest (unsafe_get_field :obdi_destlist omsnd))
	 (osel (unsafe_get_field :obmsnd_sel omsnd))
	 (orecv (unsafe_get_field :obmsnd_recv omsnd))
	 (oargs (unsafe_get_field :obmsnd_args omsnd))
	 (oxres (unsafe_get_field :obmultsnd_xres omsnd))
	 (:long nbarg (multiple_length oargs))
	 (:long nbxres (multiple_length oxres))
	 (paramdesclist (make_list discr_list))
	 (resdesclist (make_list discr_list))
	 (boxdepthp1 (make_integerbox discr_integer (+i 1 depth)))
	 )
    (output_location oloc implbuf depth "multimsend")
    (add2sbuf_strconst implbuf "/*multimsend*/{")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (if (>i nbarg 0)
	(progn
	  (add2sbuf_strconst implbuf "union meltparam_un argtab[")
	  (add2sbuf_longdec implbuf nbarg)
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ))
    (if (>i nbxres 0)
	(progn
	  (add2sbuf_strconst implbuf "union meltparam_un restab[")
	  (add2sbuf_longdec implbuf nbxres)
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ;; fill the resdesclist
	  (multiple_every 
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curestyp (get_ctype cures ())) )
	       (list_append resdesclist (unsafe_get_field :ctype_parstring curestyp)))))
	  ))
    (if (>i nbarg 0)
	(progn
	  (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))))
    (if (>i nbxres 0)
	(progn
	  (add2sbuf_strconst implbuf "memset(&restab, 0, sizeof(restab));")
	  (add2sbuf_indentnl implbuf (+i 1 depth))))
    ;; output the initialization of argtab and fill paramdesclist
    (if (>i nbarg 0)
	(progn
	  ;; output the initialization of argtab and fill the paramdesclist
	  (foreach_in_multiple
	   (oargs)
	   (curarg :long curank)
	     (let ( (curctyp (get_ctype curarg ())) )
	       (assert_msg "check curctyp" (is_a curctyp class_ctype))
	       (output_location oloc implbuf (get_int boxdepthp1) "multimsend.arg")
	       (add2sbuf_strconst implbuf "argtab[")
	       (add2sbuf_longdec implbuf   curank)
	       (add2sbuf_strconst implbuf "].")
	       (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp))
	       (cond
		( (null curarg)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL"))
		( (== curctyp ctype_value)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
		  (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		  )
		(:else
		 (add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp))
		 (add2sbuf_strconst implbuf " = ")
		 (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
		 ))
	       (add2sbuf_strconst implbuf ";")
	       )
	     (assert_msg "check limited implbuf" 
			 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
	     )
	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
	  ))
    ;; output the initialization of restab
    (if (>i nbxres 0)
	(progn
	  (multiple_every
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curestyp (get_ctype cures ())) )
	       (assert_msg "check curestyp" (is_a curestyp class_ctype))
	       (output_location oloc implbuf (get_int boxdepthp1) "multimsend.xres")
	       (add2sbuf_strconst implbuf "restab[")
	       (add2sbuf_longdec implbuf  curank)
	       (add2sbuf_strconst implbuf "].")
	       (cond
		( (null cures)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*)NULL")
		  )
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "meltbp_aptr = (melt_ptr_t*) &")
		  (output_c_code cures declbuf implbuf (get_int boxdepthp1))
		  )
		(:else
		 (add2sbuf_string implbuf (unsafe_get_field :ctype_resfield curestyp))
		 (add2sbuf_strconst implbuf " = ")
		 (output_c_code cures declbuf implbuf (get_int boxdepthp1))
		 ))
	       (add2sbuf_strconst implbuf ";")
	       )
	     ))
	  ))
    (output_location oloc implbuf (get_int boxdepthp1) "multimsend.send")
;;; output the destination(s)
    (list_every
     odest
     (lambda (curdest) 
       (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
       (add2sbuf_strconst implbuf " = ")))
    ;; output the send and the receiver
    (add2sbuf_strconst implbuf " meltgc_send ((melt_ptr_t)(")
    (output_c_code orecv declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), ((melt_ptr_t)(")
    ;; output the selector
    (output_c_code osel declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf ")), (")
    ;; output the argdescr string
    (list_every 
     paramdesclist
     (lambda (pard)
       (add2sbuf_string implbuf pard)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    ;; output the argtab (or null if none)
    (if (>i nbarg 0)
	(add2sbuf_strconst implbuf "argtab, (")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0, ("))
    ;; output the resdescr string
    (list_every
     resdesclist
     (lambda (resd)
       (add2sbuf_string implbuf resd)
       (add2sbuf_strconst implbuf " ")))
    (add2sbuf_strconst implbuf "\"\"), ")
    ;; output the extra results
    (if (>i nbxres 0)
	(add2sbuf_strconst implbuf "restab")
      (add2sbuf_strconst implbuf "(union meltparam_un*)0"))
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objmultimsend output_c_code outpucod_objmultimsend)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output a clear
(defun outpucod_objclear (oclear declbuf implbuf :long depth)
  (assert_msg "check oclear" (is_a oclear class_objclear))
  (let ( (cloc (unsafe_get_field :obi_loc oclear))
	 (cvl (unsafe_get_field :oclr_vloc oclear))
	 )
    (output_location cloc implbuf depth "clear")
    (add2sbuf_strconst implbuf "/*clear*/ ")
    (output_c_code cvl declbuf implbuf (+i depth 1))
    (add2sbuf_strconst implbuf " = 0 ")
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objclear output_c_code outpucod_objclear)

;; output a raw object allocation
(defun outpucod_objrawallocobj (oralob declbuf implbuf :long depth)
  (assert_msg "check oralob" (is_a oralob class_objrawallocobj))
  (let ( (iloc (unsafe_get_field :obi_loc oralob))
	 (iclass (unsafe_get_field :obrallobj_class oralob))
	 (iclaname (unsafe_get_field :obrallobj_classname oralob))
	 (ilen (unsafe_get_field :obrallobj_len oralob))
	 (destlist (unsafe_get_field :obdi_destlist oralob)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (assert_msg "outpucod_objrawallocobj check iclass" (is_a iclass class_objvalue))
    (output_location iloc implbuf depth "rawallocobj")
    (add2sbuf_strconst implbuf "/*rawallocobj*/ { melt_ptr_t newobj = 0;")
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "melt_raw_object_create(newobj,(melt_ptr_t)(")
    (output_c_code iclass declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "), (")
    (output_c_code ilen  declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "), \"")
    (add2sbuf_cencstring implbuf iclaname) 
    (add2sbuf_strconst implbuf "\");")
    (foreach_in_list
     destlist
     (dstpair dst) 
     (add2sbuf_indentnl implbuf (+i depth 1))
     (output_c_code dst declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		  (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     (add2sbuf_strconst implbuf " =")))
  (add2sbuf_indentnl implbuf (+i depth 1))
  (add2sbuf_strconst implbuf "newobj; };")
  (add2sbuf_indentnl implbuf depth)
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objrawallocobj output_c_code outpucod_objrawallocobj)


;; output a closure allocation
(defun outpucod_objnewclosure (obnclo declbuf implbuf :long depth)
  (assert_msg "check oralob" (is_a obnclo class_objnewclosure))
  (let ( (iloc (unsafe_get_field :obi_loc obnclo))
	 (odiscr (unsafe_get_field :obnclo_discr obnclo))
	 (orout (unsafe_get_field :obnclo_rout obnclo))
	 (olen (unsafe_get_field :obnclo_len obnclo))
	 (destlist (unsafe_get_field :obdi_destlist obnclo))
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (output_location iloc implbuf depth "newclosure")
    (add2sbuf_strconst implbuf " /*newclosure*/ ")
    (list_every
     destlist
     (lambda (dst) 
       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
       (assert_msg "check limited implbuf" 
		   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
       (add2sbuf_strconst implbuf " =")))
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "(melt_ptr_t) meltgc_new_closure((meltobject_ptr_t)(")
    (output_c_code odiscr declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "), (meltroutine_ptr_t)(")
    (output_c_code orout declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "), (")
    (output_c_code olen declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "));")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objnewclosure  output_c_code outpucod_objnewclosure)

;; output a touch
(defun outpucod_objtouch (otouch declbuf implbuf :long depth)
  (assert_msg "check otouch" (is_a otouch class_objtouch))
  (let ( (iloc (unsafe_get_field :obi_loc otouch)) 
	 (touched (unsafe_get_field :otouch_val otouch)) 
	 (comm (unsafe_get_field :otouch_comment otouch))
	 )
    (output_location iloc implbuf depth "touch")
    (if comm 
	(progn 
	  (add2sbuf_strconst implbuf "/*touch:")
	  (add2sbuf_cident implbuf comm)
	  (add2sbuf_strconst implbuf "*/")
	  (add2sbuf_indentnl implbuf depth)
	  ))
    (add2sbuf_strconst implbuf "meltgc_touch(")
    (output_c_code touched declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    )
  )
(install_method class_objtouch output_c_code outpucod_objtouch)



;; output a debug tracing of written object
(defun outpucod_dbgtracewriteobj (otwro declbuf implbuf :long depth)
  (assert_msg "check otwro" (is_a otwro class_objdbgtracewriteobj))
  (let ( (iloc (unsafe_get_field :obi_loc otwro)) 
	 (owritten (unsafe_get_field :obdtw_writtenobj otwro)) 
	 (msg (unsafe_get_field :obdtw_message otwro))
	 )
    (output_location iloc implbuf depth "touchobj")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_dbgtrace_written_object (")
    (output_c_code owritten declbuf implbuf depth)
    (add2sbuf_strconst implbuf ", \"")
    (if (is_string msg) 
	(add2sbuf_cencstring implbuf msg)
      (add2sbuf_strconst implbuf "*written object*"))
    (add2sbuf_strconst implbuf "\");")
    (add2sbuf_indentnl implbuf depth)))
(install_method class_objdbgtracewriteobj output_c_code outpucod_dbgtracewriteobj)
	     
  
;;; output a put tuple (mostly used in initial data content filling)
(defun outpucod_objputuple (optup declbuf implbuf :long depth)
  (assert_msg "check optyp" (is_a optup class_objputuple))
  (let ( (iloc (unsafe_get_field :obi_loc optup))
	 (otup (unsafe_get_field :oputu_tupled optup))
	 (ooff (unsafe_get_field :oputu_offset optup))
	 (:long uniqrank 0)
	 (oval (unsafe_get_field :oputu_value optup)) 
	 )
    (code_chunk uniqrankset 
		#{ { /* outpucod_objputuple $UNIQRANKSET */  
                static long $UNIQRANKSET#_cnt ;
		$UNIQRANKSET#_cnt++		 ;
		$UNIQRANK = $UNIQRANKSET#_cnt	 ;
		} /* end  outpucod_objputuple $UNIQRANKSET */ }#)
    (multicall 
     (linev filev)
     (line_and_file_of_location iloc)
     (output_location iloc implbuf depth "putuple")
     (add2sbuf_strconst implbuf "/*putupl")
     (add2sbuf_strconst implbuf "#")
     (add2sbuf_longdec implbuf uniqrank)
     (add2sbuf_strconst implbuf "*/")
     (add2sbuf_indentnl implbuf depth)
     (add2sbuf_strconst implbuf "melt_assertmsg(\"putupl ")
     (if (>i (get_int linev) 0)
	 (progn 
	   (add2sbuf_strconst implbuf "[")
	   (add2sbuf_string implbuf filev)
	   (add2sbuf_strconst implbuf ":")
	   (add2sbuf_longdec implbuf (get_int linev))
	   (add2sbuf_strconst implbuf "] ")
	   ))
     (add2sbuf_strconst implbuf "#")
     (add2sbuf_longdec implbuf uniqrank)
     (add2sbuf_strconst implbuf " checktup\", melt_magic_discr((melt_ptr_t)(")
     (output_c_code otup declbuf implbuf depth)
     (add2sbuf_strconst implbuf "))== MELTOBMAG_MULTIPLE);")
     (add2sbuf_indentnl implbuf depth)
     (add2sbuf_strconst implbuf "melt_assertmsg(\"putupl ")
     (if (>i (get_int linev) 0)
	 (progn 
	   (add2sbuf_strconst implbuf "[")
	   (add2sbuf_string implbuf filev)
	   (add2sbuf_strconst implbuf ":")
	   (add2sbuf_longdec implbuf (get_int linev))
	   (add2sbuf_strconst implbuf "] ")
	   ))
     (add2sbuf_strconst implbuf "#")
     (add2sbuf_longdec implbuf uniqrank)
     (add2sbuf_strconst implbuf " checkoff\", (")
     (output_c_code ooff declbuf implbuf depth)
     (add2sbuf_strconst implbuf ">=0 && ")
     (output_c_code ooff declbuf implbuf depth)
     (add2sbuf_strconst implbuf "< melt_multiple_length((melt_ptr_t)(")
     (output_c_code otup declbuf implbuf depth)
     (add2sbuf_strconst implbuf "))));")
     (add2sbuf_indentnl implbuf depth)
     (add2sbuf_strconst implbuf "((meltmultiple_ptr_t)(")
     (output_c_code otup declbuf implbuf depth)
     (add2sbuf_strconst implbuf "))->tabval[")
     (output_c_code ooff declbuf implbuf depth)
     (add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
     (output_c_code oval declbuf implbuf depth)
     (add2sbuf_strconst implbuf ");")
     (add2sbuf_indentnl implbuf depth)
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    )
  )
(install_method class_objputuple output_c_code outpucod_objputuple)

;;;;
(definstance objputpairhead_counter class_reference :referenced_value '0)

(defun outpucod_objputpairhead (oput declbuf implbuf :long depth)
  (let ( (oloc (unsafe_get_field :obi_loc oput))
	 (opair (get_field :oputp_pair oput))
	 (ohead (get_field :oputp_head oput))
	 (oldcount !objputpairhead_counter)
	 (newcount (+ivi oldcount 1))
	)
    (output_location oloc implbuf depth "putpairhead")
    (add2sbuf_strconst implbuf "/*putpairhead*/")
    (add2sbuf_indentnl implbuf depth)
    (set_ref objputpairhead_counter newcount)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putpairhead /")
    (add2sbuf_longhex implbuf (get_int newcount))
    (add2sbuf_strconst implbuf " checkpair\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code opair declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))== MELTOBMAG_PAIR);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltpair_ptr_t)(")
    (output_c_code opair declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))->hd = (melt_ptr_t) (")
    (output_c_code ohead declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
))
(install_method class_objputpairhead output_c_code outpucod_objputpairhead)

;;;;
(defun outpucod_objputpairtail (oput declbuf implbuf :long depth)
  (let ( (oloc (unsafe_get_field :obi_loc oput))
	 (opair (get_field :oputp_pair oput))
	 (otail (get_field :oputp_tail oput))
	)
    (output_location oloc implbuf depth "putpairtail")
    (add2sbuf_strconst implbuf "/*putpairtail*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putpairtail /")
    (add2sbuf_longhex implbuf (obj_hash oput))
    (add2sbuf_strconst implbuf " checkpair\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code opair declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))== MELTOBMAG_PAIR);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltpair_ptr_t)(")
    (output_c_code opair declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))->tl = (meltpair_ptr_t) (")
    (output_c_code otail declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
))
(install_method class_objputpairtail output_c_code outpucod_objputpairtail)

;;;;
(defun outpucod_objputlist (oput declbuf implbuf :long depth)
  (let ( (oloc (unsafe_get_field :obi_loc oput))
	 (olist (get_field :oputl_list oput))
	 (ofirst (get_field :oputl_first oput))
	 (olast (get_field :oputl_last oput))
	)
    (output_location oloc implbuf depth "putlist")
    (add2sbuf_strconst implbuf "/*putlist*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putlist checklist\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code olist declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))== MELTOBMAG_LIST);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltlist_ptr_t)(")
    (output_c_code olist declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))->first = (meltpair_ptr_t) (")
    (output_c_code ofirst declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltlist_ptr_t)(")
    (output_c_code olist declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))->last = (meltpair_ptr_t) (")
    (output_c_code olast declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
))
(install_method class_objputlist output_c_code outpucod_objputlist)

;;;;
(defun outpucod_objgetslot (ogsl declbuf implbuf :long depth)
  (assert_msg "check ogsl" (is_a ogsl class_objgetslot))
  (let ( (oloc (unsafe_get_field :obi_loc ogsl))
	 (destlist (unsafe_get_field :obdi_destlist ogsl))
	 (oobj (unsafe_get_field :ogetsl_obj ogsl))
	 (ofield (unsafe_get_field :ogetsl_field ogsl))
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (assert_msg "check ofield" (is_a ofield class_field))
    (output_location oloc implbuf depth "getslot")
    (add2sbuf_strconst implbuf "{ melt_ptr_t slot=NULL, obj=NULL;")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "obj = (melt_ptr_t)(");
    (output_c_code oobj declbuf implbuf depth)
    (add2sbuf_strconst implbuf ") /*=obj*/;");
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "melt_object_get_field(slot,obj, ")
    (add2sbuf_longdec implbuf (get_int ofield))
    (add2sbuf_strconst implbuf ", \"")
    (add2sbuf_string implbuf (unsafe_get_field :named_name ofield))
    (add2sbuf_strconst implbuf "\");")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (list_every
     destlist
     (lambda (dst)    
       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
       (assert_msg "check limited implbuf" 
		   (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
       (add2sbuf_strconst implbuf " = ")))
    (add2sbuf_strconst implbuf "slot; };")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objgetslot output_c_code outpucod_objgetslot)



;;; output a put slot (mostly used in initial data content filling)
(defun outpucod_objputslot (opslo declbuf implbuf :long depth)
  (assert_msg "check opslo" (is_a opslo class_objputslot))
  (let ( (iloc (unsafe_get_field :obi_loc opslo))
	 (odata (unsafe_get_field :oslot_odata opslo))
	 (ooff (unsafe_get_field :oslot_offset opslo))
	 (ofield (unsafe_get_field :oslot_field opslo))
	 (oval (unsafe_get_field :oslot_value opslo))
	 )
    (assert_msg "outpucod_objputslot check oval not nrep" (not (is_a oval class_nrep)))
    (output_location iloc implbuf depth "putslot")
    (add2sbuf_strconst implbuf "/*putslot*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putslot checkobj")
    (if (is_a odata class_named)
	(progn
	  (add2sbuf_strconst implbuf " ")
	  (add2sbuf_string implbuf (unsafe_get_field :named_name odata))))
    (if (is_a ofield class_named)
	(progn
	  (add2sbuf_strconst implbuf " @")
	  (add2sbuf_string implbuf (unsafe_get_field :named_name ofield))))
    (add2sbuf_strconst implbuf "\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code odata declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_OBJECT);")
    (add2sbuf_indentnl implbuf depth)
    (if (is_a ofield class_field)
	(progn
	  (add2sbuf_strconst implbuf "melt_putfield_object((")
	  (output_c_code odata declbuf implbuf depth)
	  (add2sbuf_strconst implbuf "), (")
	  (output_c_code ooff declbuf implbuf depth)
	  (add2sbuf_strconst implbuf "), (")
	  (output_c_code oval declbuf implbuf (+i 1 depth))
	  (add2sbuf_strconst implbuf "), \"")
	  (add2sbuf_cident implbuf (unsafe_get_field :named_name ofield))
	  (add2sbuf_strconst implbuf "\");")
	  )
      (progn
;;; this only happens for initialization of instances
	(add2sbuf_indentnl implbuf depth)
	(add2sbuf_strconst implbuf "melt_assertmsg(\"putslot checkoff")
	(if (is_a odata class_named)
	    (progn
	      (add2sbuf_strconst implbuf " ")
	      (add2sbuf_string implbuf (unsafe_get_field :named_name odata))))
	(if (is_a ofield class_named)
	    (progn
	      (add2sbuf_strconst implbuf " @")
	      (add2sbuf_string implbuf (unsafe_get_field :named_name ofield))))
	(add2sbuf_strconst implbuf "\", (")
	(output_c_code ooff declbuf implbuf depth)
	(add2sbuf_strconst implbuf ">=0 && ")
	(output_c_code ooff declbuf implbuf depth)
	(add2sbuf_strconst implbuf "< melt_object_length((melt_ptr_t)(")
	(output_c_code odata declbuf implbuf depth)
	(add2sbuf_strconst implbuf "))));")
	(add2sbuf_indentnl implbuf depth)
	(add2sbuf_strconst implbuf "((meltobject_ptr_t)(")
	(output_c_code odata declbuf implbuf depth)
	(add2sbuf_strconst implbuf "))->obj_vartab[")
	(output_c_code ooff declbuf implbuf depth)
	(add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
	(add2sbuf_indentnl implbuf (+i 1 depth))
	(output_c_code oval declbuf implbuf (+i 1 depth))
	(add2sbuf_strconst implbuf ");")
	)
      )
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objputslot output_c_code outpucod_objputslot)


;;; output the putting of the routine in a closure
(defun outpucod_objputclosurout (opclor  declbuf implbuf :long depth)
  (assert_msg "check opclor" (is_a opclor class_objputclosurout))
  (let ( (oloc (unsafe_get_field :obi_loc opclor))
	 (oclos (unsafe_get_field :opclor_clos opclor))
	 (orout (unsafe_get_field :opclor_rout opclor)) 
	 (:long cnt 0)
	 )
    (code_chunk 
     getcntchk
     #{ /* $GETCNTCHK in outpucod_objputclosurout */ {
     static long $GETCNTCHK#_cnt;
     $GETCNTCHK#_cnt++;
     $CNT = $GETCNTCHK#_cnt;
     } }#)
    (output_location oloc implbuf depth "putclosurout")
    (add2sbuf_strconst implbuf "/*putclosurout#")    
    (add2sbuf_longdec implbuf cnt)
    (add2sbuf_strconst implbuf "*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosrout#")
    (add2sbuf_longdec implbuf cnt)
    (add2sbuf_strconst implbuf " checkclo\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosrout#")
    (add2sbuf_longdec implbuf cnt)
    (add2sbuf_strconst implbuf " checkrout\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->rout = (meltroutine_ptr_t) (")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objputclosurout output_c_code outpucod_objputclosurout)

;;; output the putting of a closed value
(defun outpucod_objputclosedv (opclov declbuf implbuf :long depth)
  (assert_msg "check opclor" (is_a opclov class_objputclosedv))
  (let ( (oloc (unsafe_get_field :obi_loc opclov))
	 (oclos (unsafe_get_field :opclov_clos opclov))
	 (ooff (unsafe_get_field :opclov_off opclov))
	 (ocval (unsafe_get_field :opclov_cval opclov)) )
    (output_location oloc implbuf depth "putclosedv")
    (add2sbuf_strconst implbuf "/*putclosv*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosv checkclo\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosv checkoff\", ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">= 0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< melt_closure_size((melt_ptr_t) (")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")));")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objputclosedv output_c_code outpucod_objputclosedv)


;;; output the putting of a nonull closed value
(defun outpucod_objputclosednotnullv (opclov declbuf implbuf :long depth)
  (assert_msg "check opclor" (is_a opclov class_objputclosednotnullv))
  (let ( (oloc (unsafe_get_field :obi_loc opclov))
	 (oclos (unsafe_get_field :opclov_clos opclov))
	 (ooff (unsafe_get_field :opclov_off opclov))
	 (ocval (unsafe_get_field :opclov_cval opclov)) )
    (output_location oloc implbuf depth "putclosednotnullv")
    (add2sbuf_strconst implbuf "/*putclosvnotnull*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosvnotnull checkclo\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosvnotnull checknotnullval\", NULL != ")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosvnotnull checkoff\", ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">= 0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< melt_closure_size((melt_ptr_t) (")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")));")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objputclosednotnullv output_c_code outpucod_objputclosednotnullv)


;; output the putting of a constant value inside a routine
(defun outpucod_objputroutconst (oprconst declbuf implbuf :long depth)
  (assert_msg "check oprconst" (is_a oprconst class_objputroutconst))
  (let ( (oloc (unsafe_get_field :obi_loc oprconst))
	 (orout (unsafe_get_field :oprconst_rout oprconst))
	 (oroutnam (if (is_a orout class_objinitroutine) (unsafe_get_field :oie_cname orout)))
	 (ooff (unsafe_get_field :oprconst_off oprconst))
	 (ocval (unsafe_get_field :oprconst_cval oprconst)) )
    (output_location oloc implbuf depth "putroutconst")
    (add2sbuf_strconst implbuf "/*putroutconst*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "if (MELT_HAS_INITIAL_ENVIRONMENT) melt_assertmsg(\"putroutconst checkrout\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    ;;
    (add2sbuf_strconst implbuf "if (MELT_HAS_INITIAL_ENVIRONMENT) melt_checkmsg(\"putroutconst constnull.")
    (if (is_string oroutnam) (add2sbuf_string implbuf oroutnam))
    (add2sbuf_strconst implbuf "#")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "\", NULL != (")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf "));")
    (add2sbuf_indentnl implbuf depth)
    ;;
    (add2sbuf_strconst implbuf "((meltroutine_ptr_t)")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objputroutconst output_c_code outpucod_objputroutconst)

;; output the putting of a nonnull constant value inside a routine
(defun outpucod_objputroutconstnotnull (oprconst declbuf implbuf :long depth)
  (assert_msg "check oprconst" (is_a oprconst class_objputroutconstnotnull))
  (let ( (oloc (unsafe_get_field :obi_loc oprconst))
	 (orout (unsafe_get_field :oprconst_rout oprconst))
	 (ooff (unsafe_get_field :oprconst_off oprconst))
	 (ocval (unsafe_get_field :oprconst_cval oprconst)) )
    (assert_msg "check notnull ocval" (notnull ocval))
    (output_location oloc implbuf depth "putroutconstnotnull")
    (add2sbuf_strconst implbuf "/*putroutconstnotnull*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putroutconstnotnull checkrout\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == MELTOBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putroutconstnotnull notnullconst\", NULL != ")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((meltroutine_ptr_t)")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (melt_ptr_t)(")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    )
  )
(install_method class_objputroutconstnotnull output_c_code outpucod_objputroutconstnotnull)



;;; output the put of an extra returned result
(defun outpucod_objputxtraresult (oputx declbuf implbuf :long depth)
  (assert_msg "check oputx" (is_a oputx class_objputxtraresult))
  (let (  (oloc (unsafe_get_field :obi_loc oputx))
	  (orank (unsafe_get_field :obxres_rank oputx))
	  (ovloc (unsafe_get_field :obxres_obloc oputx))
	  (octyp (get_ctype ovloc ()))
	  )
    (output_location oloc implbuf depth "putxtraresult")
    (assert_msg "check octyp" (is_a octyp class_ctype))
    (assert_msg "check orank" (is_integerbox orank))
    (add2sbuf_strconst implbuf "if (!meltxrestab_ || !meltxresdescr_) goto labend_rout;")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "if (meltxresdescr_[")
    (add2sbuf_longdec implbuf (get_int orank))
    (add2sbuf_strconst implbuf "] != ")
    (add2sbuf_string implbuf (unsafe_get_field :ctype_parchar octyp))
    (add2sbuf_strconst implbuf ") goto labend_rout;")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "if (meltxrestab_[")
    (add2sbuf_longdec implbuf (get_int orank))
    (add2sbuf_strconst implbuf "].")
    (unless (is_string (get_field :ctype_resfield octyp))
      (debug "outpucod_objputxtraresult bad octyp" octyp " oputx=" oputx)
      (error_strv oloc "impossible secondary result type" (get_field :named_name octyp))
      )
    (add2sbuf_string implbuf (unsafe_get_field :ctype_resfield octyp))
    (add2sbuf_strconst implbuf ") *(meltxrestab_[")
    (add2sbuf_longdec implbuf (get_int orank))
    (add2sbuf_strconst implbuf "].")
    (add2sbuf_string implbuf (unsafe_get_field :ctype_resfield octyp))
    (add2sbuf_strconst implbuf ") = (")
    (if (== octyp ctype_value) (add2sbuf_strconst implbuf "melt_ptr_t) ("))
    (output_c_code ovloc declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (assert_msg "check limited implbuf" 
		(<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
    ))
(install_method class_objputxtraresult output_c_code  outpucod_objputxtraresult)

;;; output an expression
(defun outpucod_objexpv (oexp declbuf implbuf :long depth)
  (assert_msg "check oexp" (is_a oexp class_objexpv))
  (let ( (cont (unsafe_get_field :obx_cont oexp)) 
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (assert_msg "check cont" (is_multiple cont))
    (foreach_in_multiple
     (cont)
     (comp :long ix)
     (output_c_code comp declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )))
(install_method class_objexpv output_c_code outpucod_objexpv)

;;; output a located expression
(defun outpucod_objlocatedexpv (oexp declbuf implbuf :long depth)
  (assert_msg "check oexp" (is_a oexp class_objlocatedexpv))
  (let ( (cont (unsafe_get_field :obx_cont oexp)) 
	 (oloc (unsafe_get_field :obcx_loc oexp))
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 (otyp (unsafe_get_field :obv_type oexp))
	 )
    ;; the cont may be null
    (assert_msg "check cont" (is_multiple_or_null cont))
    (if (== otyp ctype_void)
	(progn
	  (add2sbuf_indentnl implbuf depth)
	  (add2sbuf_strconst implbuf "{")
	  (add2sbuf_indentnl implbuf depth)
	  (output_location oloc implbuf depth "locexp")
	  )      
      (if oloc
	  (output_raw_location oloc implbuf depth "expr")
	)
      )
    ;;
    (foreach_in_multiple
     (cont)
     (comp :long ix)
     (output_c_code comp declbuf implbuf (get_int boxdepthp1))
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (if (== otyp ctype_void)
	(progn
	  (add2sbuf_strconst implbuf ";}")
	  (add2sbuf_indentnl implbuf depth)))
    )
  (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objlocatedexpv output_c_code outpucod_objlocatedexpv)

;;; output a verbatim string
(defun outpucod_verbatimstring (vstr declbuf implbuf :long depth)
  (assert_msg "check vstr" (== (discrim vstr) discr_verbatim_string))
  (add2sbuf_string implbuf vstr)
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )


(install_method discr_verbatim_string output_c_code outpucod_verbatimstring)



;; output a string (cstring constant)
(defun outpucod_string (vstr declbuf implbuf :long depth)
  (assert_msg "check vstr" (== (discrim vstr) discr_string)) 
  (add2sbuf_strconst implbuf " \"")
  (add2sbuf_cencstring implbuf vstr)
  (add2sbuf_strconst implbuf "\"")
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method discr_string output_c_code outpucod_string)



;;; output an integer
(defun outpucod_integer (vint declbuf implbuf :long depth)
  (assert_msg "check vint" (is_integerbox vint))
  (add2sbuf_longdec implbuf (get_int vint))
  )
(install_method discr_integer output_c_code outpucod_integer)

;;; output a finalreturn
(defun outpucod_finalreturn (fret declbuf implbuf :long depth)
  (assert_msg "check fret" (is_a fret class_objfinalreturn))
  (output_location (unsafe_get_field :obi_loc fret) implbuf depth "finalreturn")
  (add2sbuf_strconst implbuf ";")
  (add2sbuf_indentnl implbuf depth)
  (add2sbuf_strconst implbuf "/*finalret*/ goto labend_rout ")
  (assert_msg "check limited implbuf" 
	      (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
  )
(install_method class_objfinalreturn output_c_code outpucod_finalreturn)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun sorted_named_dict_tuple (dic)
  (let ( (:long dicnt (mapstring_count dic))
	 (entlist (make_list discr_list)) 
	 )
    (foreach_in_mapstring
     (dic)
     (nam ent)
     (assert_msg "check ent named" (is_a ent class_named))
     (list_append entlist ent))
    (let ( (rawtup (list_to_multiple entlist))
	   )
      (assert_msg "sorted_named_dict_tuple check tuple length is dict count"
		  (==i dicnt (multiple_length rawtup)))
      (multiple_sort rawtup compare_named_alpha discr_multiple)
      )
    ))

(defun output_exported_offsets (modctx declbuf implbuf)
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( 
	(rawdictfields (unsafe_get_field :mocx_expfieldict modctx))
	(sortedfields (sorted_named_dict_tuple rawdictfields))
	(rawdictclasses (unsafe_get_field :mocx_expclassdict modctx))
	(sortedclasses (sorted_named_dict_tuple rawdictclasses))
	)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "/* exported ")
    (add2sbuf_longdec implbuf (mapstring_count rawdictfields))
    (add2sbuf_strconst implbuf " field offsets */")
    (foreach_in_multiple 
     (sortedfields)
     (fld :long ix)
     (assert_msg "check fld" (is_a fld class_field))
     (add2sbuf_indentnl implbuf 0)
     (add2sbuf_strconst implbuf "MELT_EXTERN const int meltfieldoff__")
     (add2sbuf_cident implbuf (unsafe_get_field :named_name fld))
     (add2sbuf_strconst implbuf ";")
     (add2sbuf_indentnl implbuf 0)
     (add2sbuf_strconst implbuf "const int meltfieldoff__")
     (add2sbuf_cident implbuf (unsafe_get_field :named_name fld))
     (add2sbuf_strconst implbuf " = ")
     (add2sbuf_longdec implbuf (get_int fld))
     (add2sbuf_strconst implbuf ";")
     (add2sbuf_strconst implbuf " /* in ")
     (add2sbuf_string implbuf (get_field :named_name (get_field :fld_ownclass fld)))
     (add2sbuf_strconst implbuf " */")
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "/* exported ")
    (add2sbuf_longdec implbuf (mapstring_count rawdictclasses))
    (add2sbuf_strconst implbuf " class lengths */")
    (foreach_in_multiple
     (sortedclasses)
     (cla :long ix)
     (assert_msg "check cla" (is_a cla class_class))
     (add2sbuf_indentnl implbuf 0)
     (add2sbuf_strconst implbuf "MELT_EXTERN const int meltclasslen__")
     (add2sbuf_cident implbuf (unsafe_get_field :named_name cla))
     (add2sbuf_strconst implbuf ";")
     (add2sbuf_indentnl implbuf 0)
     (add2sbuf_strconst implbuf "const int meltclasslen__")
     (add2sbuf_cident implbuf (unsafe_get_field :named_name cla))
     (add2sbuf_strconst implbuf " = ")	
     (add2sbuf_longdec implbuf 
		       (multiple_length (unsafe_get_field :class_fields cla)))
     (add2sbuf_strconst implbuf ";")
     (assert_msg "check limited implbuf" 
		 (<i (strbuf_usedlength implbuf) (get_int !buffer_limit_cont)))
     )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    ))


;;; the internal class for secondary generated C files
(defclass class_secondary_c_file
  :super class_root
  :fields (secfil_modnam 		;the module name
	   secfil_path			;the file path
	   secfil_declbuf		;the declaration buffer
	   secfil_implbuf		;the implementation buffer
	   ))

;; internal primitive to generate a C name
(defprimitive generated_c_filename (discr base dir :long num) :value
  #{meltgc_new_string_generated_c_filename /*  generated_c_filename */
     ((meltobject_ptr_t) ($DISCR),
      melt_string_str((melt_ptr_t) ($BASE)), melt_string_str((melt_ptr_t) ($DIR)), 
      ($NUM))}#)


;;; retrieve or create the nth secondary file in a module
(defun nth_secundary_file (modctx modnamstr declbuf :long ix)
    (assert_msg "check modctx" (is_a modctx class_module_context))
    (assert_msg "check modnamstr" (is_string modnamstr))
    (assert_msg "check declbuf" (is_strbuf declbuf))
    (let ( (mofiles (get_field :mocx_filetuple modctx))
	   (:long nbfiles (multiple_length mofiles))
	   (nthfile (multiple_nth mofiles ix))
	   )
      (if nthfile (return nthfile))
      (if (<=i ix 0) (return))
      (if (>=i ix nbfiles) (return))
      (compile_warning "nth_secundary_file incomplete")
      (let ( 	 
	    (path (generated_c_filename discr_string
					modnamstr
					()
					ix))
	    (implbuf (make_strbuf discr_strbuf))
	    (newfile (instance class_secondary_c_file
			       :secfil_modnam modnamstr
			       :secfil_path path 
			       :secfil_declbuf declbuf
			       :secfil_implbuf implbuf))
	    )
	(put_int newfile ix)
	(multiple_put_nth mofiles ix newfile)
	(return newfile)
	)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility to output the melt descriptor FOO+meltdesc.c and melt
;; timestamp FOO+melttime.h [#include-d by FOO+meltdesc.c] from files
(defun output_melt_descriptor (modnamstr secfiles modctx)
  (debug "output_melt_descriptor modnamstr=" modnamstr " secfiles=" secfiles " modctx=" modctx)
  (assert_msg "check modnamstr" (is_string modnamstr))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( 
	(:long nbsecfiles (multiple_length secfiles))
	(:long lastsecfileix 0)
	(debuf (make_strbuf discr_strbuf))
	(tibuf (make_strbuf discr_strbuf))
	(mkbuf (make_strbuf discr_strbuf))
	(pathlist (make_list discr_list))
	(md5list (make_list discr_list))
	(modbuildstr (make_string_nakedbasename discr_string modnamstr))
	(modcident (let ( (buf (make_strbuf discr_strbuf))
			  )
		     (add2out_cident buf modnamstr)
		     (strbuf2string discr_string buf)))
	(modbuildcident (let ( (buf (make_strbuf discr_strbuf))
			  )
		     (add2out_cident buf modbuildstr)
		     (strbuf2string discr_string buf)))
	(modprefstr (string4out discr_string "$(GCCMELTGEN_BUILD)" modbuildstr))
	(packagepclist (get_field :mocx_packagepclist modctx))
	(flavortuple
	 (tuple '"quicklybuilt" '"optimized" '"dynamic" '"debugnoline"))
	)
    (add2sbuf_strconst debuf "/** GENERATED MELT DESCRIPTOR FILE ")
    (add2sbuf_ccomstring debuf modnamstr)
    (add2sbuf_strconst debuf "+meltdesc.c \n** NEVER EDIT OR MOVE THIS, IT IS GENERATED & PARSED! **/")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "/* These identifiers are generated in warmelt-outobj.melt \n & handled in melt-runtime.c carefully. */") 
    (add2sbuf_indentnl debuf 0)
    (add2out mkbuf "## GENERATED MELT MAKE FRAGMENT FILE " modnamstr "+meltbuild.mk\n")
    (add2out mkbuf "## NEVER EDIT THIS FILE, generated from warmelt-outobj.melt by output_melt_descriptor\n")
    (add2out debuf ##{
	     #ifdef __cplusplus
	     /* explicitly declare as extern "C" our dlsym-ed symbols */
	     extern "C" const char melt_versionmeltstr[]	    ;
	     extern "C" const char melt_genversionstr[]		    ;
	     extern "C" const char melt_modulename[]		    ;
	     extern "C" const char melt_modulerealpath[]	    ;
	     extern "C" const char melt_prepromd5meltrun[]	    ;
	     extern "C" const char melt_primaryhexmd5[]		    ;
	     extern "C" const char* const melt_secondaryhexmd5tab[] ;
	     extern "C" const int melt_lastsecfileindex		    ;
	     extern "C" const char melt_cumulated_hexmd5[]	    ;

	     extern "C" {
	     #endif /*__cplusplus */
	     }#)
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "/* version of the GCC compiler & MELT runtime generating this */")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "const char melt_genversionstr[]=\"")
    (code_chunk 
     genversch
     #{ /* output_melt_descriptor $GENVERSCH + */
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, melt_gccversionstr) ;
     }#)
    (add2sbuf_strconst debuf "\"")
    (add2sbuf_indentnl debuf 0)
    (add2out debuf ##{
	     #ifdef __cplusplus
	     " (in C++)"
	     #else
	     " (in C)"
	     #endif
					;
	     }#)
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "const char melt_versionmeltstr[]=\"")
    (add2out mkbuf "## generated by MELT version ")
    (code_chunk 
     genvmeltch
     #{ /* output_melt_descriptor $GENVMELTCH + */
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, melt_version_str ()) ;
     meltgc_add_strbuf_cstr ((melt_ptr_t) $MKBUF, melt_version_str ()) ;
     }#)
    (add2sbuf_strconst debuf "\";")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_indentnl mkbuf 0)
    ;;
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "/* source name & real path of the module */")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "/*MELTMODULENAME ")
    (add2sbuf_ccomstring  debuf modnamstr)
    (add2sbuf_strconst debuf " */")
    (add2sbuf_indentnl debuf 0)
    (add2out mkbuf "#module name and identifier\n")
    (add2out mkbuf "MELTGEN_MODULENAME=" modnamstr)
    (add2sbuf_indentnl mkbuf 0)
    (add2out mkbuf "MELTGEN_MODULEIDENT=" modcident)
    (add2sbuf_indentnl mkbuf 0)
    (add2sbuf_strconst debuf "const char melt_modulename[]=\"")
    (code_chunk
     genmodnamstr
     #{ /* output_melt_descriptor $GENMODNAMSTR + */
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, lbasename (melt_string_str((melt_ptr_t) $MODNAMSTR))) ;
     }#
     )
    ;;
    (add2sbuf_strconst debuf "\";")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "const char melt_modulerealpath[]=\"")
    (code_chunk 
     genrpathch
     #{ /* output_melt_descriptor $GENRPATHCH + */ {
     char* lrp = lrealpath (melt_string_str ((melt_ptr_t) $MODNAMSTR)) ;
     if (!melt_flag_bootstrapping && !IS_ABSOLUTE_PATH(lrp)) {
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, getpwd()) ;
     meltgc_add_strbuf ((melt_ptr_t) $DEBUF, "/")	    ;
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, lrp)      ;
     }
     else if (melt_flag_bootstrapping) {
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, melt_module_dir) ;
     meltgc_add_strbuf ((melt_ptr_t) $DEBUF, "/")		   ;
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, lbasename (lrp)) ;
     }
     else      
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, lrp) ;
     free (lrp)					       ;
     } /* end output_melt_descriptor $GENRPATHCH */}#)
    (add2sbuf_strconst debuf "\";")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "/* hash of preprocessed melt-run.h generating this */")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "const char melt_prepromd5meltrun[]=\"")
    (code_chunk 
     genversch
     #{ /* output_melt_descriptor $GENVERSCH */
     meltgc_add_strbuf_cstr ((melt_ptr_t) $DEBUF, MELT_RUN_HASHMD5) ;
     }#)
    (add2sbuf_strconst debuf "\";")
    (add2sbuf_indentnl debuf 0)
    ;;
    (add2sbuf_strconst debuf "/* hexmd5checksum of primary C file */")
    (add2sbuf_indentnl debuf 0)
    (add2sbuf_strconst debuf "const char melt_primaryhexmd5[]=\"")
    (let ( 
	  (primpath (string4out discr_string modnamstr ".c")) 
	  (primmd5s (string_hex_md5sum_pathstrv primpath))
	  (mkrulebuf (make_strbuf discr_strbuf))
	  (secmd5buf (make_strbuf discr_strbuf))
	  (secpathbuf (make_strbuf discr_strbuf))
	  )
      (debug "output_melt_descriptor primpath=" primpath)
      (list_append pathlist primpath)
      (list_append md5list primmd5s)
      (add2sbuf_cencstring debuf primmd5s)
      (add2out mkbuf "#primary path and checksum\n")
      (add2out mkbuf "MELTGENMOD_PRIMPATH_" modcident "=" primpath)
      (add2sbuf_indentnl mkbuf 0)
      (add2out mkbuf "MELTGENMOD_MD5PRIM_" modcident "=" primmd5s)
      (add2sbuf_indentnl mkbuf 0)
      ;; emit pkg-config information in make fragment
      (let ( (packagepctup (list_to_multiple packagepclist discr_multiple))
	     (:long nbpackagepc (multiple_length packagepctup))
	     )
	(debug "output_melt_descriptor packagepctup=" packagepctup)
	(when nbpackagepc
	  (add2out mkbuf "# " nbpackagepc " packages for pkg-config utility\n")
	  (add2out mkbuf "MELTGENMOD_PACKAGELIST_PKGCONFIG_" modcident "=")
	  (foreach_in_multiple 
	   (packagepctup)
	   (curpack :long pkix)
	   (add2out mkbuf " " curpack))
	  (add2out mkbuf "\n# global name for these pkg-config packages:\n")
	  (add2out mkbuf "MELTGENMOD_PACKAGELIST=$(MELTGENMOD_PACKAGELIST_PKGCONFIG_" modcident ")\n")
	)
	(unless nbpackagepc
	  (add2out mkbuf "# no packages needed thru pkg-config\n"))
	)
      (add2out mkrulebuf "### generated dependencies for " modnamstr "\n\n")
      (add2out mkrulebuf "# dependency for primary of " modcident "\n")
      (foreach_in_multiple
       (flavortuple)
       (curflav :long flavix)
       (add2out mkrulebuf modprefstr "." primmd5s "." curflav ".meltpic.o: " primpath "\n")
       )
      (add2sbuf_strconst debuf "\";")
      (add2sbuf_indentnl debuf 0)
      ;;
      (add2sbuf_indentnl debuf 0) 
      (add2sbuf_strconst debuf "/* hexmd5checksum of secondary C files */")
      (add2sbuf_indentnl debuf 0)
      (add2sbuf_strconst debuf "const char* const melt_secondaryhexmd5tab[]={")
      ;;
      (debug "output_melt_descriptor secfiles=" secfiles)
      (foreach_in_multiple
       (secfiles)
       (curfil :long filix)
       (debug "output_melt_descriptor curfil=" curfil " filix=" filix)
       (add2sbuf_indentnl debuf 1)
       (if curfil
	   (progn
	     (assert_msg "output_melt_descriptor check curfil" 
			 (is_a curfil class_secondary_c_file))
	     (setq lastsecfileix filix)
	     (let ( (secpath (get_field :secfil_path curfil)) 
		    (secmd5s (string_hex_md5sum_pathstrv secpath))
		    )
	       (list_append pathlist secpath)
	       (list_append md5list secmd5s)
	       (add2sbuf_strconst debuf "/*sechexmd5checksum ")
	       (add2sbuf_ccomstring debuf secpath)
	       (add2sbuf_strconst debuf " #")
	       (add2sbuf_longdec debuf (get_int curfil))
	       (add2sbuf_strconst debuf " */ \"")
	       (add2sbuf_cencstring debuf secmd5s)
	       (add2sbuf_strconst debuf "\",")
	       (add2out secpathbuf " " secpath)
	       (add2out secmd5buf " " secmd5s)
	       ;; make secondary dependencies
	       (add2out mkrulebuf "# dependencies for secondary " filix " of " modcident "\n")
	       (foreach_in_multiple
		(flavortuple)
		(curflav :long flavix)
		(add2out mkrulebuf modprefstr "+" 
			 (if (<i filix 10) "0" "") 
			 filix "." secmd5s "." curflav ".meltpic.o: " modnamstr "+" 
			 (if (<i filix 10) "0" "") 
			 filix ".c" "\n")
		)
	       ))
	 (add2sbuf_strconst debuf "/*nosecfile*/ (const char*)0,")
	 ))				;end foreach secondary file
      (add2sbuf_indentnl debuf 1)
      (add2sbuf_strconst debuf "(const char*)0 };")
      (add2sbuf_indentnl debuf 0)
      ;;
      (add2sbuf_indentnl debuf 0)
      (add2sbuf_strconst debuf "/* last index of secondary files */")
      (add2sbuf_indentnl debuf 0)
      (add2sbuf_strconst debuf "const int melt_lastsecfileindex=")
      (add2sbuf_longdec  debuf lastsecfileix)
      (add2sbuf_strconst debuf ";")
      (add2sbuf_indentnl debuf 0)
      (add2out mkbuf "#secondary paths and checksums\n")
      (add2out mkbuf  "MELTGENMOD_SECONDARY_FILES_" modcident "=" (strbuf2string discr_string secpathbuf) "\n")
      (add2sbuf_indentnl mkbuf 0)
      (add2out mkbuf  "MELTGENMOD_SECONDARY_MD5SUMS_" modcident "=" (strbuf2string discr_string secmd5buf) "\n")
      (add2sbuf_indentnl mkbuf 0)
      ;;
      (let ( (cumpathmds (string_hex_md5sum_path_sequence
			  (list_to_multiple pathlist)))
	     (midstr (make_string_nakedbasename
		      discr_string modnamstr)) 
	     (modidnam (let ( (mout (make_strbuf discr_strbuf)) 			    
			      )
			 (add2out mout "meltmod_")
			 (add2sbuf_cident mout midstr)
			 (add2out mout "_mds__")
			 (add2sbuf_cident mout cumpathmds)
			 (strbuf2string discr_string mout))
		       )
	     )
	(assert_msg "check cumpathmds" (is_string cumpathmds)) 
	;;
	(add2out mkrulebuf "## dependency for descriptor object of " modnamstr "\n")
	(add2out mkrulebuf  modprefstr "."  cumpathmds ".descriptor.meltpic.o: " modnamstr "+meltdesc.c " 
		 modnamstr "+melttime.h\n")
	;;
	(add2out mkrulebuf "## dependency for modules " modnamstr "\n")
	(foreach_in_multiple
	 (flavortuple)
	 (curflav :long flavix)
	 (add2out mkrulebuf "\n#### dependencies for flavor " curflav " of module " modnamstr "\n\n")
	 ;; old flavored dependencies; the .meltmod is at end
	 (add2out mkrulebuf "\n## old fashion dependency for flavor " curflav " of module " modnamstr "\n")
	 (add2out mkrulebuf modprefstr "." cumpathmds "." curflav ".meltmod.so: \\\n"
		  "  " modprefstr "."  cumpathmds ".descriptor.meltpic.o "
		  )
	 (let ( (pathtup (list_to_multiple pathlist discr_multiple))
		(md5tup (list_to_multiple md5list discr_multiple))
		)
	   (assert_msg "check same length pathtup md5tup" (==i (multiple_length pathtup) (multiple_length md5tup)))
	   (foreach_in_multiple
	    (pathtup)
	    (curpath :long ix)
	    (let ( (curmd5 (multiple_nth md5tup ix))
		   )
	      (debug "output_melt_descriptor curpath=" curpath " ix=" ix " curmd5=" curmd5)
	      (add2out mkrulebuf " \\\n   "  "$(GCCMELTGEN_BUILD)" (make_string_nakedbasename discr_string curpath) 
		       "." curmd5 "." curflav ".meltpic.o")
	      )
	    )
	   )
	 ;; new flavored dependencies; the .meltmod- is before the md5sum 
	 (add2out mkrulebuf "\n\n## new dependency for flavor " curflav " of module " modnamstr "\n")
	 (add2out mkrulebuf modprefstr ".meltmod-" cumpathmds "." curflav ".so: \\\n"
		  "  " modprefstr "."  cumpathmds ".descriptor.meltpic.o "
		  )
	 (let ( (pathtup (list_to_multiple pathlist discr_multiple))
		(md5tup (list_to_multiple md5list discr_multiple))
		)
	   (assert_msg "check same length pathtup md5tup" (==i (multiple_length pathtup) (multiple_length md5tup)))
	   (foreach_in_multiple
	    (pathtup)
	    (curpath :long ix)
	    (let ( (curmd5 (multiple_nth md5tup ix))
		   )
	      (debug "output_melt_descriptor curpath=" curpath " ix=" ix " curmd5=" curmd5)
	      (add2out mkrulebuf " \\\n   "  "$(GCCMELTGEN_BUILD)" (make_string_nakedbasename discr_string curpath) 
		       "." curmd5 "." curflav ".meltpic.o")
	      )
	    )
	   )
	 (add2out mkrulebuf "\n\n")
	 ) ;; end foreach flavortuple
	;;
	(add2out mkrulebuf "\n#end of generated dependencies for " modnamstr "\n\n")
	(add2out mkbuf mkrulebuf)
	(setq mkrulebuf ())
	(add2out mkbuf "## cumulated checksum and naked name\n")
	(add2out mkbuf "MELTGENMOD_CUMULATED_MD5SUM_" modcident "=" cumpathmds "\n")
	(add2out mkbuf "MELTGENMOD_NAKED_NAME_" modcident "=" midstr "\n")
	(add2sbuf_indentnl debuf 0) 
	(add2out 
	 debuf 
	 ##{/* cumulated checksum of primary & secondary files */
const char melt_cumulated_hexmd5[]="$CUMPATHMDS" ;

/* include the timestamp file */
#define $MODIDNAM 1
#include "$MIDSTR+melttime.h"
	 }#
	 )
	;;
	;;
	(add2sbuf_strconst tibuf "/** GENERATED MELT TIMESTAMP FILE ")
	(add2sbuf_ccomstring tibuf modnamstr)
	(add2sbuf_strconst tibuf "+melttime.h \n** NEVER EDIT OR MOVE THIS, IT IS GENERATED & PARSED! **/")
	(add2sbuf_indentnl tibuf 0)
	(add2sbuf_strconst tibuf "/* These identifiers are generated in warmelt-outobj.melt \n & handled in melt-runtime.c carefully. */") 
	(add2sbuf_indentnl tibuf 0)
	(add2sbuf_indentnl tibuf 0) 
	(add2out tibuf ##{
/* This $MIDSTR+melttime.h is included from $MIDSTR+meltdesc.c only. */
#if $MODIDNAM
/* MELT generation timestamp for $MODNAMSTR */

#ifdef __cplusplus
/* these symbols are extern "C" since dlsym-ed */
extern "C" const char melt_gen_timestamp[] ;
extern "C" const long long melt_gen_timenum ;
extern "C" const char melt_build_timestamp[] ;
extern "C" {
#endif /*__cplusplus */

		 }#
		 )
	(add2sbuf_indentnl tibuf 0)
        (code_chunk 
         gentimch
         #{ /* output_melt_descriptor $GENTIMCH + */ {
         time_t now = 0 ;
         char nowbuf[64] ;
         time (&now) ;
         memset (nowbuf, 0, sizeof(nowbuf)) ;
         strftime (nowbuf, sizeof(nowbuf)-1, "%c %Z", localtime(&now)) ;
         if (melt_flag_bootstrapping)
           meltgc_add_strbuf ((melt_ptr_t) $TIBUF, "/*MELT BOOTSTRAP*/\n") ;
         meltgc_add_strbuf ((melt_ptr_t) $TIBUF, 
                            "const char melt_gen_timestamp[]=\"") ;
         meltgc_add_strbuf_cstr ((melt_ptr_t) $TIBUF, nowbuf) ;
         meltgc_add_strbuf ((melt_ptr_t) $TIBUF, "\";\n") ;
         /*  $GENTIMCH don't use time_t, it is not a predefined C type! */
         meltgc_strbuf_printf ((melt_ptr_t) $TIBUF, 
                               "const long long melt_gen_timenum=%lld;",
                               (long long) now) ;              
         } /* output_melt_descriptor $GENTIMCH - */}#)
	(add2sbuf_indentnl tibuf 0)
	(add2out tibuf ##{
		 const char melt_build_timestamp[]= __DATE__ "@" __TIME__
		 #ifdef __cplusplus
		 " (in C++)"
		 #else
		 " (in C)"
		 #endif /*__cplusplus*/
					;
		 }#)
	(add2sbuf_indentnl tibuf 0)
	(add2out tibuf ##{
		 #ifdef __cplusplus
		 }  /* end extern C timestamp */
		 #endif /*__cplusplus */

		 #else /* ! $MODIDNAM */
		 #error invalid timestamp file for $MODNAMSTR 
		 #endif /* $MODIDNAM */
		 }#)
	(add2sbuf_indentnl tibuf 0)
	;;
	(add2sbuf_indentnl debuf 0)
	(add2out debuf ##{
		 #ifdef __cplusplus
		 }	  /* end extern C descriptor */
		 #endif /*__cplusplus */
		 }#)
	(add2sbuf_indentnl debuf 0)
	(add2sbuf_strconst debuf "/* end of melt descriptor file */")
	(add2sbuf_indentnl debuf 0)
	(add2out mkbuf "\n## eof of generated " modnamstr "+meltbuild.mk\n")
	)
      (let (
	    (meltdescpath (string4out discr_string  modnamstr "+meltdesc.c"))
	    (melttimepath (string4out discr_string  modnamstr "+melttime.h"))
	    (meltmakepath (string4out discr_string  modnamstr "+meltbuild.mk"))
	    )
	(debug "output_melt_descriptor meltdescpath=" meltdescpath 
	       "\n* debuf=" debuf)
	(debug "output_melt_descriptor melttimepath=" melttimepath 
	       "\n* tibuf=" tibuf)
	(debug "output_melt_descriptor meltmakepath=" meltmakepath 
	       "\n* mkbuf=" mkbuf)
	(output_sbuf_no_overwrite_strval debuf meltdescpath)
	(output_sbuf_no_overwrite_strval tibuf melttimepath)
	(output_sbuf_no_overwrite_strval mkbuf meltmakepath)
	(debug "output_melt_descriptor final modctx=" modctx)
	)
      )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(defselector syntax_test_generator
  class_selector
  :doc #{Selector to emit C syntax for testing purposes of a generator
device.  Reciever is the representation -e.g. $CLASS_PRIMITIVE,
... $GENDEV is the generator device, $SBUF is the string buffer,
$MODCTX is the module context, and $IX is the index.}#
  :formals (recv gendev sbuf modctx :long ix)
)

(defun syntestgen_any (recv gendev sbuf modctx :long ix)
  (let ( (dis (discrim recv))
	 (disname (get_field :named_name dis))
	 (dloc (get_field :loca_location gendev))
	 )
    (debug "syntestgen_any recv=" recv "\n* dis=" dis
	   "\n* gendev=" gendev
	   "\n* sbuf=" sbuf
	   "\n* modctx=" modctx
	   "\n* ix=" ix)
    (error_strv dloc "unimplemented SYNTAX_TEST_GENERATOR method for " disname)
    (assert_msg "check gendev" (is_a gendev class_source_generator_device))
    (assert_msg "check sbuf" (is_strbuf sbuf))
    (assert_msg "check modctx" (is_a modctx class_module_context))
    (assert_msg "@$@unimplemented syntax_test_generator")
))
(install_method discr_any_receiver syntax_test_generator syntestgen_any)
		


(defun substitute_formals_for_syntest (sbuf replmap formals :cstring prefix)
  (debug "substitute_formals_for_syntest sbuf=" sbuf "\n replmap=" replmap "\n* formals=" formals "\n prefix=" prefix)
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (assert_msg "check replmap" (is_mapobject replmap))
  (assert_msg "check formals" (is_multiple_or_null formals))
  (foreach_in_multiple
   (formals)
   (curformal :long ix)
   (debug "substitute_formals_for_syntest curformal=" curformal " ix=" ix)
   (assert_msg "check curformal" (is_a curformal class_formal_binding))
   (let ( (fsymb (get_field :binder curformal))
	  (ftype (get_field :fbind_type curformal))
	  (gensy (let ( (nambuf (make_strbuf discr_strbuf))
			)
		   (add2out nambuf prefix ix "_")
		   (add2sbuf_cident nambuf (get_field :named_name fsymb))
		   (strbuf2string discr_verbatim_string nambuf))) 
	  )
     (mapobject_put replmap fsymb gensy)
     (debug "substitute_formals_for_syntest updated replmap=" replmap "\n with fsymb=" fsymb "\n with gensy=" gensy)
     (add2out sbuf (get_field :ctype_cname ftype) " " gensy " =0;")
     (add2sbuf_indentnl sbuf 1)
     ))
  )
  

(defun expand_tuple_for_syntest (sbuf replmap tup loc)
  (debug "expand_tuple_for_syntest sbuf=" sbuf "\n replmap=" replmap "\n tup=" tup)
  (foreach_in_multiple 
   (tup) 
   (curexpan :long pix)
   (debug "expand_tuple_for_syntest curexpan=" curexpan)
   (if (is_object curexpan)
       (let ( (curepl (mapobject_get replmap curexpan))
	      )
	 (debug "expand_tuple_for_syntest curepl=" curepl) 
	 (if curepl
	     (add2out sbuf curepl)
	   (let ( (curexpnam (get_field :named_name curexpan))
		  )
	     (debug "expand_tuple_for_syntest no curepl for curexpan=" curexpan " replmap=" replmap)
	     (warning_strv 
	      loc "unexpected symbol in expansion [syntax check]" curexpnam)
	     )))
     (add2out sbuf curexpan))
   ) ;;end foreach tup
  (debug "expand_tuple_for_syntest done sbuf=" sbuf)
  )

;;;;;;;;;;;;;;;;
(defun syntestgen_primitive (recv gendev sbuf modctx :long ix)
  (debug "syntestgen_primitive recv=" recv " gendev=" gendev)
  (assert_msg "check recv" (is_a recv class_primitive))
  (assert_msg "check gendev" (is_a gendev class_source_generator_device))
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( (dloc (get_field :loca_location gendev))
	 (pridef (get_field :srcgen_defin gendev))
	 (prirep (get_field :srcgen_repr gendev))
	 (prinam (get_field :named_name recv))
	 (priformals (get_field :prim_formals recv))
	 (exploc (or (get_field :sprim_exploc pridef) dloc))
	 (pritype (get_field :prim_type recv))
	 (primexpan (get_field :prim_expansion recv))
	 (replmap (make_mapobject discr_map_objects 
				  (+i 5 (*i 2 (multiple_length priformals)))))
	 )
    (assert_msg "check pridef" (is_a pridef class_source_defprimitive))
    (assert_msg "check prirep" (== prirep recv))
    (add2out sbuf "/*primitive-syntax ")
    (add2sbuf_ccomstring sbuf prinam)
    (add2out sbuf "*/ {")
    (add2sbuf_indentnl sbuf 1)
    (substitute_formals_for_syntest sbuf replmap priformals "primf_")
    ;;
    (if (!= pritype ctype_void)
	(let  ( (pritynam (get_field :ctype_cname pritype))
		)
	  (add2out sbuf ##{$PRITYNAM primres_$IX = }#)
	  ))
;;;
    (if exploc (output_raw_location exploc sbuf 0 "primitive-syntax"))
    (if (!= pritype ctype_void) 
	(add2out sbuf "    "))
    (debug "syntestgen_primitive primexpan=" primexpan)
    (expand_tuple_for_syntest sbuf replmap primexpan exploc)
    ;;
    (if (!= pritype ctype_void)
	(let  ( (pritynam (get_field :ctype_cname pritype))
		)
	  (add2out sbuf ";")
	  (add2sbuf_indentnl sbuf 2)
	  (add2out sbuf ##{if (primres_$IX) return}#
		   )
	  ))
    (add2out sbuf ";")
    (add2sbuf_indentnl sbuf 1)
    (add2out sbuf "} /*end primitive-syntax ")
    (add2sbuf_ccomstring sbuf prinam)
    (add2out sbuf "*/")
    (add2sbuf_indentnl sbuf 0)
    ))

(install_method class_primitive syntax_test_generator syntestgen_primitive)


;;;


;;;;;;;;;;;;;;;;
(defun syntestgen_citerator (recv gendev sbuf modctx :long ix)
  (debug "syntestgen_citerator recv=" recv " gendev=" gendev)
  (assert_msg "check recv" (is_a recv class_citerator))
  (assert_msg "check gendev" (is_a gendev class_source_generator_device))
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( (dloc (get_field :loca_location gendev))
	 (citdef (get_field :srcgen_defin gendev))
	 (citrep (get_field :srcgen_repr gendev))
	 (citnam (get_field :named_name recv))
	 (citstaformals (get_field :citer_start_formals recv))
	 (citstate (get_field :citer_state recv))
	 (citbodformals (get_field :citer_body_formals recv))
	 (citexpbefo (get_field :citer_expbefore recv))
	 (citexpafte (get_field :citer_expafter recv))
	 (replmap (make_mapobject discr_map_objects (*i 2 (+i 3 (multiple_length citstaformals)))))
	 (repstatnam (let ( (nbuf (make_strbuf discr_strbuf)) 
			    )
		       (add2out nbuf "meltcitstate_" ix "_")
		       (add2sbuf_cident nbuf (get_field :named_name citstate))
		       (strbuf2string discr_verbatim_string nbuf)))
	 (befloc (or (get_field :sciterdef_beforeloc citdef) dloc))
	 (aftloc (or (get_field :sciterdef_afterloc citdef) dloc))
	 )
    (assert_msg "check citdef" (is_a citdef class_source_defciterator))
    (assert_msg "check citrep" (== citrep recv))
    (add2out sbuf "/*citerator-syntax ")
    (add2sbuf_ccomstring sbuf citnam)
    (add2out sbuf "*/ {")
    (add2sbuf_indentnl sbuf 1)
    (if dloc (output_raw_location dloc sbuf 0 "citerator-syntax"))
    (mapobject_put replmap citstate repstatnam)
    (debug "syntestgen_citerator replmap=" replmap)
    (substitute_formals_for_syntest sbuf replmap citstaformals "citstart_")
    (substitute_formals_for_syntest sbuf replmap citbodformals "citbody_")
    (if befloc (output_raw_location befloc sbuf 0 "citerator-syntax-before"))
    (expand_tuple_for_syntest sbuf replmap citexpbefo befloc)
    (debug "syntestgen_citerator after start formals replmap=" replmap)
    (add2sbuf_indentnl sbuf 0)
    (add2out sbuf "/**fictive body of citerator " repstatnam " **/")
    (add2sbuf_indentnl sbuf 0)
    (debug "syntestgen_citerator citbodformals=" citbodformals)
    (foreach_in_multiple
     (citbodformals)
     (curbodformbind :long bodformix)
     (debug "syntestgen_citerator curbodformbind=" curbodformbind)
     (let (
	   (curbodformal (get_field :binder curbodformbind))
	   (nambodformal (mapobject_get replmap curbodformal))
	    )
       (debug "syntestgen_citerator nambodformal=" nambodformal)
       (assert_msg "check nambodformal" nambodformal)
       (add2out sbuf "if (" NAMBODFORMAL ") return;")
       (add2sbuf_indentnl sbuf 0)
     ))
    (if aftloc (output_raw_location aftloc sbuf 0 "citerator-syntax-after"))
    (expand_tuple_for_syntest sbuf replmap citexpafte aftloc)
    (add2sbuf_indentnl sbuf 0)
    (add2out sbuf "} /*end citerator-syntax ")
    (add2sbuf_ccomstring sbuf citnam)
    (add2out sbuf "*/")
    (add2sbuf_indentnl sbuf 0)
    ))

(install_method class_citerator syntax_test_generator syntestgen_citerator)


;;;;;;;;;;;;;;;;
(defun syntestgen_cmatcher (recv gendev sbuf modctx :long ix)
  (debug "syntestgen_cmatcher recv=" recv " gendev=" gendev)
  (assert_msg "check recv" (is_a recv class_cmatcher))
  (assert_msg "check gendev" (is_a gendev class_source_generator_device))
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( (dloc (get_field :loca_location gendev))
	 (cmatdef (get_field :srcgen_defin gendev))
	 (cmatrep (get_field :srcgen_repr gendev))
	 (cmatnam (get_field :named_name recv))
	 (cmatins (get_field :amatch_in recv))
	 (cmatbind (get_field :amatch_matchbind recv))
	 (cmatout (get_field :amatch_out recv))
	 (cmatstate (get_field :cmatch_state recv))
	 (cmattest (get_field :cmatch_exptest recv))
	 (cmatfill (get_field :cmatch_expfill recv))
	 (cmatoper (get_field :cmatch_expoper recv))
	 (testloc (or (get_field :scmatdef_testloc cmatdef) dloc))
	 (fillloc (or (get_field :scmatdef_fillloc cmatdef) dloc))
	 (operloc (or (get_field :scmatdef_operloc cmatdef) dloc))
	 (replmap (make_mapobject discr_map_objects 
				  (+i 5 (*i 2 (+i (multiple_length cmatins) 
						  (multiple_length cmatout))))))
	 (repstatnam (let ( (nbuf (make_strbuf discr_strbuf)) 
			    )
		       (add2out nbuf "cmatstate_" ix "_")
		       (add2sbuf_cident nbuf (get_field :named_name cmatstate))
		       (strbuf2string discr_verbatim_string nbuf)))
	 )
    (add2out sbuf "/*cmatcher-syntax ")
    (add2sbuf_ccomstring sbuf cmatnam)
    (add2out sbuf "**/ {")
    (add2sbuf_indentnl sbuf 1)
    (mapobject_put replmap cmatstate repstatnam)
    (substitute_formals_for_syntest sbuf replmap (tuple cmatbind) "cmatched_")
    (substitute_formals_for_syntest sbuf replmap cmatins "cmatinput_")
    (substitute_formals_for_syntest sbuf replmap cmatout "cmatoutput_")
    (add2sbuf_indentnl sbuf 1)
    (if testloc (output_raw_location testloc sbuf 0 "cmatcher-syntax-test"))
    (add2out sbuf "if (/*cmatcher-test " cmatnam ":*/")
    (expand_tuple_for_syntest sbuf replmap cmattest testloc)
    (add2out sbuf "/*cmatcher-endtest*/) {")
    (add2sbuf_indentnl sbuf 2)
    (if fillloc (output_raw_location fillloc sbuf 0 "cmatcher-syntax-fill"))
    (add2out sbuf "/*cmatcher-fill " cmatnam ":*/")
    (add2sbuf_indentnl sbuf 2)
    (expand_tuple_for_syntest sbuf replmap cmatfill fillloc)
    (add2out sbuf ";")
    (add2sbuf_indentnl sbuf 2)
    (foreach_in_multiple
     (cmatout)
     (curmatoutbind :long outix)
     (debug "syntestgen_cmatcher curmatoutbind=" curmatoutbind)
     (let (
	   (curoutformal (get_field :binder curmatoutbind))
	   (namoutformal (mapobject_get replmap curoutformal))
	   )
       (debug "syntestgen_cmatcher curmatoutbind=" curmatoutbind
	      " namoutformal=" namoutformal)
       (assert_msg "check namoutformal " namoutformal)
       (add2out sbuf "if (" NAMOUTFORMAL ") return;")
       (add2sbuf_indentnl sbuf 2)
       )
     )
    (add2out sbuf "} /*cmatcher-endfill " cmatnam " */ else return;")
    (add2sbuf_indentnl sbuf 1)
    (if cmatoper
	(progn
	  (if operloc (output_raw_location operloc sbuf 0 "cmatcher-syntax-oper"))
	  (expand_tuple_for_syntest sbuf replmap 
				    (tuple '"/*cmatcher-oper*/" (get_field :binder cmatbind)  '" = ") 
				    operloc)
	  (expand_tuple_for_syntest sbuf replmap cmatoper operloc)
	  (add2out sbuf ";")
	  (add2sbuf_indentnl sbuf 2)
	  ))
    (add2out sbuf "} /*end cmatcher-syntax ")
    (add2sbuf_ccomstring sbuf cmatnam)
    (add2out sbuf "**/")
    (add2sbuf_indentnl sbuf 0)
    ))

(install_method class_cmatcher syntax_test_generator syntestgen_cmatcher)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun emit_syntax_testing_routine (gendevtup modctx sbuf)
  (debug "emit_syntax_testing_routine gendevtup=" gendevtup 
	 " sbuf=" sbuf)
  (assert_msg "check gendevtup" (is_multiple gendevtup))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (let ( 
	(:long nbgendev (multiple_length gendevtup))
	(modnam (get_field :mocx_modulename modctx))
	(syntestname 
	 (let ( (nabuf (make_strbuf discr_strbuf)) )
	   (add2out nabuf "melt_syntax_tester_")
	   (add2sbuf_cident nabuf modnam)
	   (strbuf2string discr_verbatim_string nabuf)))
	)
    (debug "emit_syntax_testing_routine syntestname=" syntestname)
    (assert_msg "check syntestname" (is_string syntestname))
    (add2sbuf_indentnl sbuf 0)
    (add2sbuf_indentnl sbuf 0)
    (add2sbuf_indentnl sbuf 0)
    (add2out sbuf "/****** emitted syntax checking for C generating devices *****/")
    (add2sbuf_indentnl sbuf 0)
    (add2out sbuf "#if MELT_HAVE_DEBUG")
    (add2sbuf_indentnl sbuf 0)
    (add2out 
     sbuf ##{
/* generated syntax checking routine for $NBGENDEV C generating devices */
MELT_EXTERN void MELT_MODULE_VISIBILITY $SYNTESTNAME (void);

void
$SYNTESTNAME (void) {
if (1) return;
}#)
    (foreach_in_multiple
     (gendevtup)
     (curgendev :long gix)
     (add2sbuf_indentnl sbuf 1)
     (debug "emit_syntax_testing_routine curgendev=" curgendev "\n gix#" gix)
     (assert_msg "check curgendev" (is_a curgendev class_source_generator_device))
     (let ( (:long sucgix (+i gix 1))
	    (repr (get_field :srcgen_repr curgendev))
	    )
       (add2sbuf_indentnl sbuf 0)
       (add2out sbuf ##{/* generating device #$SUCGIX */}#)
       (add2sbuf_indentnl sbuf 0)
       (debug "emit_syntax_testing_routine before syntax_test_generator repr=" repr)
       (syntax_test_generator repr curgendev sbuf modctx gix)
       (debug "emit_syntax_testing_routine after syntax_test_generator repr=" repr "\n gix#" gix "\n")
       )
     (add2sbuf_indentnl sbuf 0)
     ) ;; end foreach gendevtup
     (add2sbuf_indentnl sbuf 0)
     (add2out 
      sbuf 
      ##{} /* end generated $SYNTESTNAME */}#)
     (add2sbuf_indentnl sbuf 0)
     (add2out sbuf "#endif /*MELT_HAVE_DEBUG syntaxcheck*/")
     (add2sbuf_indentnl sbuf 0)
     (add2sbuf_indentnl sbuf 0)
     ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal utility function to normalize & declare a macroexpanded list
;; return the normalized list, the declaration buffer, the start clock
(defun normadeclb_macroexpanded_list (xlist modnamstr modctx ncx inienv)
  (debug "normadeclb_macroexpanded_list start xlist= " xlist
	 "\n* modnamstr=" modnamstr 
	 "\n* modctx=" modctx
	 "\n* ncx=" ncx
	 "\n* inienv=" inienv)
  (assert_msg "check xlist" (is_list xlist))
  (assert_msg "check modnamstr" (is_string modnamstr))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check inienv" (is_a inienv class_environment))
  (debug "normadeclb_macroexpanded_list modctx=" modctx)
  (let (
	(:long startclock 0)
	(normlist (list))
	(declbuf (make_strbuf discr_strbuf))
	(firstx (pair_head (list_first xlist)))
	(firstloc (if (is_a firstx class_source) (get_field :loca_location firstx)))
	(errorhdlr (get_field :mocx_errorhandler modctx))
	(modinienv (get_field :mocx_initialenv modctx))
	(iniproc (get_field :nctx_initproc ncx))
	(cheadlist (get_field :mocx_cheaderlist modctx))
	;; make an update_current_module_environment at the very beginning
	(ucmeb1 (instance class_source_update_current_module_environment_container
			  :loca_location firstloc
			  :sucme_comment '"at very start"
			  ))
	)
    (debug "normadeclb_macroexpanded_list modctx=" modctx)
    (debug "normadeclb_macroexpanded_list @@cheadlist=" cheadlist)
    (code_chunk startmodnam
		#{ /* normadeclb_macroexpanded_list $STARTMODNAM */
		#if HAVE_CLOCK
		$STARTCLOCK = (long) clock () ;
		#endif /*HAVE_CLOCK */
		#if MELT_HAVE_DEBUG
		inform  (UNKNOWN_LOCATION, 
			 "MELT [#%ld] generating C code of module %s", 
			 melt_dbgcounter, melt_string_str ((melt_ptr_t) $MODNAMSTR)) ;
		#else
		inform  (UNKNOWN_LOCATION, 
			 "MELT generating C code of module %s", 
			 melt_string_str ((melt_ptr_t) $MODNAMSTR)) ;
		#endif /* MELT_HAVE_DEBUG */
		}#)
    (add2sbuf_indentnl declbuf 0)
    ;; special hack to copy the first comment before anything else,
    ;; practically useful to make the copyright comment appear really
    ;; early in generated declaration buffer.
    (when (is_a firstx class_source_comment)
      (list_popfirst xlist)
      (let ( (sloc (unsafe_get_field :loca_location firstx))
	     (scomm (unsafe_get_field :scomm_str firstx)) 
	     )
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_strconst 
	 declbuf 
	 "/***************************************************")
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_ccomstring declbuf scomm)
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_strconst 
	 declbuf 
	 "****************************************************/")
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_indentnl declbuf 0)
	)
      )
    (debug "normadeclb_macroexpanded_list modctx=" modctx 
	   "\n with @@cheadlist=" cheadlist)
    ;; only warmelt-first.melt gets a zeroed MELT_HAS_INITIAL_ENVIRONMENT
    (if modinienv
	(progn
	  (debug "normadeclb_macroexpanded_list usual modinienv=" modinienv)
	  (add2sbuf_strconst declbuf "/* ordinary MELT module */")
	  (add2sbuf_indentnl declbuf 0)
	  (add2sbuf_strconst declbuf "#define MELT_HAS_INITIAL_ENVIRONMENT 1 /*usual*/"))
      (progn
	(debug "normadeclb_macroexpanded_list initial modinienv=" modinienv)
	(add2sbuf_strconst declbuf "/* initial MELT module */")
	(add2sbuf_indentnl declbuf 0)
	(code_chunk check_warmelt_first_bootstrapping_chunk #{ 
		    /* $CHECK_WARMELT_FIRST_BOOTSTRAPPING_CHUNK */ 
		    melt_checkmsg ("bootstrapping first file",
				   melt_flag_bootstrapping 
				   && melt_string_str((melt_ptr_t) $MODNAMSTR)
				   && strstr(melt_string_str((melt_ptr_t) $MODNAMSTR), "first")) ;
		    }#)
	;; lack of initial environment happens only in translateinit mode for warmelt-first.melt
	(add2sbuf_strconst declbuf "#define MELT_HAS_INITIAL_ENVIRONMENT 0 /*initial*/")))
    ;;
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_strconst declbuf "struct melt_callframe_st; /*defined in melt-runtime.h*/")
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (list_prepend xlist ucmeb1)
    ;;
    ;; we need to normalize now, because cheaders are handled by normalization
    (list_every
     xlist
     (lambda (sexp :long ix)
       (debug "normadeclb_macroexpanded_list sexp=" sexp " ix=" ix)
       (let (
	     (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp)))
	     )
	 ;; special hack to handle toplevel comments specially; the generated comment goes into the declbuf
	 ;; practically useful to copy a copyright notice into the generated C code
	 (if (is_a sexp class_source_comment)
	     (let ( (sloc (unsafe_get_field :loca_location sexp))
		    (scomm (unsafe_get_field :scomm_str sexp)) 
		    )
	       (add2sbuf_indentnl declbuf 0)
	       (add2sbuf_strconst declbuf "/**!!** ")
	       (add2sbuf_ccomstring declbuf scomm)
	       (add2sbuf_strconst declbuf "**!!**/")
	       (add2sbuf_indentnl declbuf 0)
	       )
;;; otherwise, normalize etc.
	   (multicall 
	    (nexp nbind)
	    (normal_exp sexp inienv ncx psloc)	    
	    (debug "normadeclb_macroexpanded_list nexp=" nexp " nbind=" nbind)    
	    (if (and (is_a nexp class_nrep)
		     (not (is_a nexp class_nrep_anyproc)))
		(let ( (wnexp (wrap_normal_let1 nexp nbind psloc)) )
		  (debug "normadeclb_macroexpanded_list wnexp=" wnexp)
		  (list_append (unsafe_get_field :ninit_topl iniproc) 
			       wnexp)
		  ))
	    (list_append normlist nexp)
	    )))))

    (debug "normadeclb_macroexpanded_list @@cheadlist=" cheadlist "\n modctx=" modctx)
    ;; handle cheaders, should be done after normalization which is filling cheadlist
    (let (
	  (cheadtup (list_to_multiple cheadlist discr_multiple))
	  (:long nbchead (multiple_length cheadtup))
	  )
      (debug "normadeclb_macroexpanded_list cheadtup=" cheadtup "\n nbchead=" nbchead
	     "\n @@cheadlist=" cheadlist)
      (if (>i nbchead 0)
	  (progn
	    (add2sbuf_indentnl declbuf 0)
	    (add2sbuf_indentnl declbuf 0)
	    (add2out declbuf ##{/***** $NBCHEAD extra C headers *****/}#)
	    (add2sbuf_indentnl declbuf 0)
	    (add2sbuf_indentnl declbuf 0)
	    (foreach_in_multiple
	     (cheadtup)
	     (curchead :long hix)
	     (debug "normadeclb_macroexpanded_list curchead=" curchead " hix=" hix)
	     (assert_msg "check curchead" (is_a curchead class_source_cheader))
	     (add2sbuf_indentnl declbuf 0)
	     (add2out declbuf ##{/** header #$HIX: **/}#)
	     (add2sbuf_indentnl declbuf 0)
	     (let ( (hloc (get_field :loca_location curchead))
		    (chstr (get_field :scheader_codestring curchead))
		    )
	       (if hloc
		   (output_raw_location hloc declbuf 0 "cheader"))
	       (add2out declbuf chstr)
	       (add2sbuf_indentnl declbuf 0)
	       )
	     )
	    (add2sbuf_indentnl declbuf 0)
	    (add2sbuf_indentnl declbuf 0)
	    (add2out declbuf ##{/***** end of $NBCHEAD extra C headers *****/}#)
	    (add2sbuf_indentnl declbuf 0)
	    (add2sbuf_indentnl declbuf 0)
	    ))
      (debug "normadeclb_macroexpanded_list  @@cheadlist=" cheadlist)
      )
    ;;
    (assert_msg "check iniproc" (is_a iniproc class_nrep_initproc))
    (assert_msg "check xlist" (is_list xlist))
    ;;
    
    (return normlist declbuf startclock)
    ))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility function to translate a macroexpanded list
(defun translate_macroexpanded_list (xlist modnamstr modctx ncx inienv normalisthandler iniproctransl)
  ;; XLIST is the list of macro-expanded things, usually instances of
  ;; subclasses of class_source
  ;;
  ;; MODNAMSTR is the name string of the module
  ;;
  ;; MODCTX is the module generation context of class_module_context
  ;;
  ;; NCX is the normalization context, of class_normalization_context
  ;;
  ;; INIENV is the initial environment, of class_environment
  ;;
  ;; NORMALISTHANDLER is null or a closure to post-process the
  ;; normalized list
  ;;
  ;; INIPROCTRANSL is the translator of the initial routine
  ;;
  ;;;;;;;;;;;;;;;;
  (debug "translate_macroexpanded_list modnamstr=" modnamstr "\n* modctx=" modctx
	 "\n* inienv=" inienv
	 "\n* iniproctransl=" iniproctransl)
  (assert_msg "check xlist" (is_list xlist))
  (assert_msg "check modnamstr" (is_string modnamstr))
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check inienv" (is_a inienv class_environment))
  (assert_msg "translate_macroexpanded_list modulename not ended with MELT_DYNLOADED_SUFFIX."
	      (not (string_dynloaded_suffixed modnamstr)))
  (assert_msg "translate_macroexpanded_list modulename not ended with .melt"
	      (not (string_suffixed modnamstr ".melt")))
  (assert_msg "translate_macroexpanded_list modulename not ended with .c"
	      (not (string_suffixed modnamstr ".c")))
  (let (
	(:long endclock 0)
	(errorhdlr (get_field :mocx_errorhandler modctx))
	(gendevlist (get_field :mocx_gendevlist modctx))
	(modinienv (get_field :mocx_initialenv modctx))
	(iniproc (get_field :nctx_initproc ncx))
	(implbuf (make_strbuf discr_strbuf)) 
	)
    (debug "translate_macroexpanded_list modinienv=" modinienv " modnamstr=" modnamstr
	   " before normadeclb_macroexpanded_list modctx=" modctx)
    (multicall
     (normlist declbuf :long startclock)
     (normadeclb_macroexpanded_list xlist modnamstr modctx ncx inienv)
     (assert_msg "check normlist" (is_list normlist))
     (assert_msg "check declbuf" (is_strbuf declbuf))
     (debug "translate_macroexpanded_list after normadeclb_macroexpanded_list modctx=" modctx
	    "\n normalisthandler=" normalisthandler)
     (when (is_closure normalisthandler)
       (debug "translate_macroexpanded_list before calling normalisthandler normlist=" normlist)
       (normalisthandler normlist modctx ncx inienv)
       (debug "translate_macroexpanded_list after calling normalisthandler normlist=" normlist)
       )
     ;;
     ;;
     (when (melt_error_counter)
       (if (is_closure errorhdlr) 
	   (errorhdlr '"MELT translation failed after normalization"))
       (code_chunk errorednormal_warnchk 
		   #{ /* translate_macroexpanded_list $ERROREDNORMAL_WARNCHK */
		   warning (0, "MELT translation of %s got after normalization %ld MELT errors",
			       melt_string_str((melt_ptr_t) $MODNAMSTR), melt_error_counter) ;
		   }#)
       (return))
     ;;
     ;;
     (let ( (prolist (unsafe_get_field :nctx_proclist ncx)) 
	    (objlist (make_list discr_list))
	    (compicache (make_mapobject discr_map_objects (+i 10 (*i 20 (list_length xlist)))))
	    (countbox (make_integerbox discr_integer 0))
	    ) 
       (debug "translate_macroexpanded_list prolist=" prolist) 
       ;;
       ;; compile each procedure and check for errors
       (assert_msg "check prolist" (is_list prolist))
       (list_every
	prolist
	(lambda (pro)
	  (assert_msg "check pro" (is_a pro class_nrep_anyproc))
	  (put_int countbox (+i (get_int countbox) 1))
	  (let ( (objpro (compile2obj_procedure pro modctx compicache (get_int countbox))) )
	    (debug "translate_macroexpanded_list objpro=" objpro " pro=" pro)
	    (list_append objlist objpro)
	    )))
       (when (melt_error_counter)
	 (if (is_closure errorhdlr) 
	     (errorhdlr '"MELT translation failed after generation"))
	 (code_chunk erroredgener_warnchk 
		     #{ /* translate_macroexpanded_list $ERROREDGENER_WARNCHK */
		     warning (0, "MELT translation of %s got after generation %ld MELT errors",
				 melt_string_str((melt_ptr_t) $MODNAMSTR), melt_error_counter) ;
		     }#)
	 (return))
       ;;
       ;; compile the initial procedure
       (assert_msg "check objlist" (is_list objlist))
       (let ( (inipro (unsafe_get_field :nctx_initproc ncx)) 
	      (inidata (unsafe_get_field :nctx_datalist ncx))
	      (importvalues (unsafe_get_field :nctx_valuelist ncx))
	      (procurmodenvlist (unsafe_get_field :nctx_procurmodenvlist ncx))
	      )
	 (debug "translate_macroexpanded_list before compiling initproc inipro=" inipro
		"\n iniproctransl=" iniproctransl)
	 (assert_msg "check inipro" (is_a inipro class_nrep_initproc))
	 (assert_msg "check iniproctransl" (is_closure iniproctransl))
	 (let ( (iniobj
		 (iniproctransl inipro modctx inidata compicache procurmodenvlist importvalues)) 
		)
	   ;;
	   (foreach_in_list
	    (objlist)
	    (pairel obel)
	    (debug "translate_macroexpanded_list obel=" obel)
	    ;; we do want to generate several C files...
	    (let ( (:long filnum
			  (if (is_a obel class_procroutineobj)
			      (get_int (get_field :oprout_filenum obel))))
		   (secfil 
		    (if filnum (nth_secundary_file modctx modnamstr declbuf filnum)))
		   (outimplbuf 
		    (if secfil (get_field :secfil_implbuf secfil) implbuf))
		   )
	      (output_c_code obel declbuf outimplbuf 0)))
;;;
	   (debug "translate_macroexpanded_list final modnamstr=" modnamstr " iniobj=" iniobj) 
	   (add2sbuf_indentnl implbuf 0)
	   (add2sbuf_indentnl implbuf 0)
;;;;; emit the syntax generator
	   (let ( (gendevtup (list_to_multiple  gendevlist discr_multiple))
		  (:long nbgendev (multiple_length gendevtup))
		  )
	     (debug "translate_macroexpanded_list before emit_syntax_testing_routine gendevtup=" gendevtup
		    " gendevlist=" gendevlist)
	     (if nbgendev
		 (emit_syntax_testing_routine gendevtup modctx implbuf)
	       (add2sbuf_strconst implbuf "/*no syntax testing generated*/")
	       ))
	   ;;
	   (add2sbuf_indentnl implbuf 0)
;;;; emit the initial routine
	   (output_c_code iniobj declbuf implbuf 0)
	   (output_exported_offsets modctx declbuf implbuf)
	   ;; output warnings if the buffer are half the limit
	   (if (>i (strbuf_usedlength declbuf) (/iraw (get_int !buffer_limit_cont) 2))
	       (warningmsg_strv "very large declaration string buffer for module " modnamstr))
	   (if (>i (strbuf_usedlength implbuf) (/iraw (get_int !buffer_limit_cont) 2))
	       (warningmsg_strv "very large implementation string buffer module for " modnamstr))
	   ;;
	   (code_chunk outputcfile
		       #{ /* translate_macroexpanded_list $OUTPUTCFILE: */
		       melt_output_cfile_decl_impl
		       ((melt_ptr_t)($MODNAMSTR),
			(melt_ptr_t)($DECLBUF),
			(melt_ptr_t)($IMPLBUF)) ;
		       }#)
	   ;;(informsg_strv "warmelt generated module C file" modnamstr)
	   (let ( (secfiles (get_field :mocx_filetuple modctx)) 
		  (:long nbsecfiles 0)
		  (:long lgsecfiles (multiple_length secfiles))
		  (:long hisecfilerk 0)
		  )
	     (debug "translate_macroexpanded_list secfiles=" secfiles)
	     (foreach_in_multiple
	      (secfiles)
	      (curfil :long filix)
	      (if curfil
		  (progn
		    (assert_msg "check curfil" 
				(is_a curfil class_secondary_c_file))
		    (assert_msg "check curfil index" 
				(==i (get_int curfil) filix))
		    (setq hisecfilerk filix)
		    (increment nbsecfiles 1)
		    ;;(setq nbsecfiles (+i nbsecfiles 1))
		    (let ( (secfilpath (get_field :secfil_path curfil))
			   (secdeclbuf (get_field :secfil_declbuf curfil))
			   (secimplbuf (get_field :secfil_implbuf curfil))
			   )
		      ;; output warnings if the buffer are half the limit
		      (if (>i (strbuf_usedlength secdeclbuf) (/iraw (get_int !buffer_limit_cont) 2))
			  (warningmsg_strv "very large declaration string buffer for secondary file " secfilpath))
		      (if (>i (strbuf_usedlength secimplbuf) (/iraw (get_int !buffer_limit_cont) 2))
			  (warningmsg_strv "very large implementation string buffer for secondary file " secfilpath))
		      ;;
		      (code_chunk 
		       secfilout 
		       #{ /* translate_macroexpanded_list $SECFILOUT: */
		       melt_output_cfile_decl_impl_secondary 
		       ((melt_ptr_t)($SECFILPATH),
			(melt_ptr_t)($SECDECLBUF),
			(melt_ptr_t)($SECIMPLBUF),
			$FILIX)		;
		       }#)
		      ;;(informsg_strv "warmelt generated secondary C file" secfilpath)
		      ))
		))
	     ;;
	     ;; output the descriptive C file 
	     (debug "translate_macroexpanded_list before output descrfil modctx=" modctx)
	     (output_melt_descriptor modnamstr secfiles modctx)
	     ;; remove the old extra files
	     (foreach_long_upto 
	      ((+i hisecfilerk 1) (+i hisecfilerk 25))
	      (:long delfilix)
	      (if (>i delfilix 0)
		  (let ( (delfilnam (generated_c_filename discr_string modnamstr () delfilix))
			 (baksbuf (make_strbuf discr_strbuf))
			 )
		    (add2out baksbuf delfilnam "~")
		    (let ( (bakfilnam (strbuf2string discr_string baksbuf))
			   )
		      (debug "translate_macroexpanded_list delfilix=" delfilix)
		      (code_chunk 
		       backupchk
		       #{ /*translate_macroexpanded_list $BACKUPCHK*/ {
		       const char* $BACKUPCHK#_delfilnamstr =
		       melt_string_str ((melt_ptr_t) $DELFILNAM) ;
		       const char* $BACKUPCHK#_bakfilnamstr = 
		       melt_string_str ((melt_ptr_t) $BAKFILNAM) ;
		       if ($BACKUPCHK#_delfilnamstr && $BACKUPCHK#_bakfilnamstr
						    && !access ($BACKUPCHK#_delfilnamstr, F_OK)) {
		       if (!rename ($BACKUPCHK#_delfilnamstr, $BACKUPCHK#_bakfilnamstr)) 
		       inform (UNKNOWN_LOCATION, "MELT backing up previous generated file %s as %s", 
						 $BACKUPCHK#_delfilnamstr, $BACKUPCHK#_bakfilnamstr) ;
		       }
		       $BACKUPCHK#_delfilnamstr = NULL ;
		       $BACKUPCHK#_bakfilnamstr = NULL ;
		       } /*end translate_macroexpanded_list $BACKUPCHK*/ }#)
		      ))))
	     ;;
	     (debug "translate_macroexpanded_list before endmodnamchk modctx=" modctx)
	     (code_chunk 
	      endmodnam
	      #{ /* translate_macroexpanded_list $ENDMODNAM */
	      #if HAVE_CLOCK && defined (CLOCKS_PER_SEC)
	      $ENDCLOCK = (long) clock () ;
	      if (melt_flag_bootstrapping)
	      inform (UNKNOWN_LOCATION, 
		      "MELT generated C code of module %s with %ld secondary files in %ld CPU millisec [#%ld].", 
		      melt_string_str ((melt_ptr_t) $MODNAMSTR), $NBSECFILES,
		      ($ENDCLOCK - $STARTCLOCK) / (CLOCKS_PER_SEC/1000), melt_dbgcounter) ;
	      else
	      inform (UNKNOWN_LOCATION, 
		      "MELT generated C code of module %s with %ld secondary files in %ld CPU millisec.", 
		      melt_string_str ((melt_ptr_t) $MODNAMSTR), $NBSECFILES,
		      ($ENDCLOCK - $STARTCLOCK) / (CLOCKS_PER_SEC/1000)) ;
	      #else /* no clock */
	      inform (UNKNOWN_LOCATION, 
		      "MELT generated C code of module %s with %ld secondary files", 
		      melt_string_str ((melt_ptr_t) $MODNAMSTR), $NBSECFILES) ;
	      #endif /* HAVE_CLOCK && CLOCKS_PER_SEC */
	      /* end translate_macroexpanded_list $ENDMODNAM */ }#)
	     (debug "translate_macroexpanded_list ending modctx=" modctx)
	     (shortbacktrace_dbg "translate_macroexpanded_list ended" 25)
	     (when (melt_error_counter)
	       (if (is_closure errorhdlr) 
		   (errorhdlr '"MELT translation failed after C code emission"))
	       (code_chunk errorednormal_warnchk 
			   #{ /* translate_macroexpanded_list $ERROREDNORMAL_WARNCHK */
			   warning (0, "MELT translation of %s got after emission %ld MELT errors",
				       melt_string_str((melt_ptr_t) $MODNAMSTR), melt_error_counter) ;
			   }#)
	       (return))
	     )))))))
  



;; utility to handle compilation errors as fatal ones
(defun fatal_compile_error (modnamstr v)
  (if (is_string v)
      (code_chunk
       fatalerrormsg_chk 
       #{ /*fatal_compile_error $FATALERRORMSG_CHK */
       melt_fatal_error ("MELT failed to compile module %s (%ld errors): %s",
			 melt_string_str ((melt_ptr_t) $MODNAMSTR),
			 melt_error_counter,
			 melt_string_str ((melt_ptr_t) $V)) ;
       }#)
    (code_chunk 
     fatalerror_chk 
     #{ /* fatal_compile_error $FATALERROR_CHK */
     melt_fatal_error ("MELT failed to compile module %s (%ld errors)",
		       melt_string_str ((melt_ptr_t) $MODNAMSTR),
		       melt_error_counter) ;
     }#))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compile a list of sexpressions as a module starting from a given environment
(defun compile_list_sexpr (lsexp inienv modnamstr)
  (message_dbg "starting  compile_list_sexpr")
  (debug "@*@@@@ compile_list_sexpr lsexp=" lsexp "\n@ compile_list_sexpr  inienv=" inienv
	 "\n@ compile_list_sexpr  modnamstr=" modnamstr) 
  (assert_msg "check lsexp" (is_list lsexp))
  (assert_msg "check modnamstr" (is_string modnamstr))
  (assert_msg "check inienv" (or (null inienv) (is_a inienv class_environment)))
  (assert_msg "compile_list_sexpr modulename not ended with MELT_DYNLOADED_SUFFIX."
	      (not (string_dynloaded_suffixed modnamstr)))
  (assert_msg "compile_list_sexpr modulename not ended with .melt"
	      (not (string_suffixed modnamstr ".melt")))
  (assert_msg "compile_list_sexpr modulename not ended with .c"
	      (not (string_suffixed modnamstr ".c")))
  (let (
	(modnakedname (make_string_nakedbasename discr_string modnamstr))
	(modctx (instance class_module_context
			  :mocx_modulename  modnakedname
			  :mocx_expfieldict (make_mapstring discr_map_strings 390)
			  :mocx_expclassdict (make_mapstring discr_map_strings 140)
			  :mocx_initialenv inienv
			  :mocx_funcount (make_integerbox discr_integer 0)
			  :mocx_filetuple ()
			  :mocx_cheaderlist (make_list discr_list)
			  ;; :mocx_cflags (make_list discr_list)
			  ;; :mocx_linkflags (make_list discr_list)
			  :mocx_packagepclist (make_list discr_list)
			  :mocx_gendevlist (make_list discr_list)
			  :mocx_errorhandler (lambda (v) (fatal_compile_error modnamstr v))
			  ))
	(ncx (create_normcontext modctx)) 
	)
    (debug "compile_list_sexpr modctx=" modctx 
	   "\n of class " (discrim modctx))
    ;; is it very unusual that inienv is null, only happenning in
    ;; translateinit mode, when bootstrapping warmelt-first.melt
    (when (null inienv)
      (code_chunk 
       checkbootstrapping_chk
       #{ /* $CHECKBOOTSTRAPPING_CHK */
       if (!melt_flag_bootstrapping)
       melt_fatal_error ("lack of initial environment can only happen during MELT bootstrapping in module %s",
			 melt_string_str ((melt_ptr_t) $MODNAKEDNAME)) ;
       }#)
      ;; we set inienv to be able to macroexpand and translate the rest. However, mocx_initialenv is null.
      (setq inienv initial_environment))
    (debug "compile_list_sexpr initial ncx=" ncx)
    (assert_msg "check ncx" (is_a ncx class_normalization_context))
    (let ( (xlist (macroexpand_toplevel_list lsexp inienv macroexpand_1 modctx)) 
	   (:long lenxlist (list_length xlist))
	   )
      (debug "compile_list_sexpr after macroexpansion modctx=" modctx)
      ;;
      (if (<=i lenxlist 3)
	  (code_chunk warnshortchk
		      #{/* compile_list_sexpr $WARNSHORTCHK*/
		      warning (0, "MELT expanded few (%d) expressions", (int) $LENXLIST) ;
		      }#))
      (debug "compile_list_sexpr before translation modctx=" modctx)
      ;;
      (translate_macroexpanded_list xlist modnamstr modctx ncx inienv () compile2obj_initproc)
      (debug "compile_list_sexpr after translation modctx=" modctx)
      )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun translate_run_melt_expressions (exprs env)
  :doc #{Translate and run the MELT s-expressions from $EXPRS in the
  $ENV environment, which can be modified, e.g. by definitions inside
  the $EXPRS. The last expression should preferably gives a value,
  which is returned...}#
  (debug "translate_run_melt_expressions start exprs=" exprs "\n*env=" env)
  (when (null exprs) 
    (debug "translate_run_melt_expressions gets and gives null")
    (return ()))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (:long num 0)
	 (:long starterrcount (melt_error_counter))
	 (nakedbasnam ())
	 (referr (instance class_reference))
	 )
    (code_chunk numchk #{/* translate_run_melt_expressions $NUMCHK */ static long num_$NUMCHK ;
		char basbuf_$NUMCHK[64]				   ;
		memset (basbuf_$NUMCHK, 0, sizeof(basbuf_$NUMCHK)) ;
		num_$NUMCHK++					   ;
		$NUM = num_$NUMCHK				   ;
		snprintf (basbuf_$NUMCHK, sizeof(basbuf_$NUMCHK), 
					  "MELTrun%04lx", num_$NUMCHK) ;
		$NAKEDBASNAM = meltgc_new_string_raw_len ((meltobject_ptr_t)MELT_PREDEF (DISCR_STRING),
							  basbuf_$NUMCHK, -1) ;
		}#)
    (debug "translate_run_melt_expressions nakedbasnam=" nakedbasnam " num=" num " starterrcount=" starterrcount)
    (let (
	  (runerrorhdlr (lambda (v)
			  (debug "runerrorhdlr v=" v)
			  (cond 
			   ((is_string v)
			    (code_chunk warnrunstr_chk
					#{ /* translate_run_melt_expressions $WARNRUNSTR_chk */
					warning (0, "MELT running expression {%s} error - %s", 
						    melt_string_str ((melt_ptr_t) $NAKEDBASNAM), 
						    melt_string_str ((melt_ptr_t) $V)) ; }#
					))
			   (:else 
			    (code_chunk warnrun_chk
					#{ /* translate_run_melt_expressions $WARNRUN_chk */
					warning (0, "MELT running expression {%s} errored", 
						    melt_string_str ((melt_ptr_t) $NAKEDBASNAM)) ; }#
					))
			   )
			  (set_ref referr (or v :true))))
	  (modctx (instance class_running_extension_module_context
			    :mocx_modulename  nakedbasnam
			    :mocx_expfieldict (make_mapstring discr_map_strings 71)
			    :mocx_expclassdict (make_mapstring discr_map_strings 19)
			    :mocx_initialenv env
			    :mocx_funcount (make_integerbox discr_integer 0)
			    :mocx_filetuple ()
			    :mocx_cheaderlist (make_list discr_list)
			    ;; :mocx_cflags (make_list discr_list)
			    ;; :mocx_linkflags (make_list discr_list)
			    :mocx_packagepclist (make_list discr_list)
			    :mocx_gendevlist (make_list discr_list)
			    :mocx_errorhandler runerrorhdlr
			    :morcx_litervalist (list ())
			    :morcx_countlitval (make_integerbox discr_integer 1)
			    :morcx_literobjmap (make_mapobject discr_map_objects 53)
			    ))
	  (ncx (create_normal_extending_context modctx env))
	  (lsexp
	   (let
	       ( (ls (make_list discr_list))
		 (addexp 
		  (lambda (curexp :long ix)
		    (cond
		     ((null curexp)
		      (void))
		     ((is_a curexp class_sexpr)
		      (list_append ls curexp))
		     ((is_a curexp class_symbol)
		      (list_append ls curexp))
		     ((is_string curexp)
		      (list_append ls curexp))
		     ((is_integerbox curexp)
		      (list_append ls curexp))
		     ((is_closure curexp)
		      (debug "translate_run_melt_expressions closure curexp=" curexp " ix=" ix)
		      (curexp ls))
		     (:else
		      (debug "translate_run_melt_expressions bad curexp=" curexp " ix=" ix)
		      (let ( (curdis (discrim curexp))
			     (curdisname (get_field :named_name curdis))
			     )
			(code_chunk badexp_chk
				    #{ /* translate_run_melt_expressions $BADEXP_CHK */
				    warning (0, "MELT run %s expression #%d has bad disciminant %s",
						melt_string_str ((melt_ptr_t) $NAKEDBASNAM),
						1+(int) $IX, 
						melt_string_str ((melt_ptr_t) $CURDISNAME)) ;
				    }#)
			(runerrorhdlr '"Bad expression")))
		     )
		    ))
		 )
	     (cond
	      ((null exprs)
	       (void))
	      ((is_multiple exprs)
	       (foreach_in_multiple
		(exprs)
		(curexp :long ix)
		(addexp curexp ix)
		))
	      ((is_list exprs)
	       (let ((:long ix 0))
		 (foreach_in_list
		  (exprs)
		  (curpair curexp)
		  (setq ix (-i ix 1))
		  (addexp curexp ix))))
	      ((is_a exprs class_sexpr)
	       (addexp exprs -999999))
	      (:else
	       (runerrorhdlr '"No expressions")))
	     ls))
	  )
      ;;macro expand
      (debug "translate_run_melt_expressions modctx=" modctx "\n ncx=" ncx "\n lsexp=" lsexp)
      (when !referr
	(runerrorhdlr '"runtime invalid expressions")
	(return () ()))
      (let ( (xlist (macroexpand_toplevel_list lsexp env macroexpand_1 modctx)) 
	     (:long lenxlist (list_length xlist))
	     ;; normalextend should ensure that the last normal gives a value
	     (normalextend 
	      (lambda (normlist modctx ncx inienv)
		(debug "translate_run_melt_expressions/normalextend normlist=" normlist)
		(let ( (lastnorm (list_last_element normlist))
		       (lastctyp (get_ctype lastnorm inienv))
		       )
		  (debug "translate_run_melt_expressions/normalextend lastnorm=" lastnorm " lastctyp=" lastctyp)
		  ;; we really should box the last stuff and return
		  ;; the boxed value
		  (when (!= lastctyp ctype_value)
		    (warningmsg_strv 
		     "runtime expressions don't end with a :value giving expression, appending () to them."
		     (get_field :named_name lastctyp))
		    (list_append normlist (instance class_nrep_nil))
		    (debug "translate_run_melt_expressions/normalextend updated normlist=" normlist)
		    )
		  )))
	     )
	(debug "translate_run_melt_expressions xlist=" xlist)
	(when (or (notnull !referr) (>i (melt_error_counter) starterrcount))
	  (runerrorhdlr '"runtime macroexpansion failed")
	  (return () ()))
	(let ( (basename (make_string_tempname_suffixed discr_string nakedbasnam "_eXt"))
	       )
	  (debug "translate_run_melt_expressions basename=" basename)
	  ;; translate to C code
	  (translate_macroexpanded_list xlist basename modctx ncx env 
					normalextend compile2obj_initextendproc)
	  (debug "translate_run_melt_expressions after translation to nakedbasnam=" nakedbasnam)
	  (when  (or (notnull !referr) (>i (melt_error_counter) starterrcount))
	    (runerrorhdlr '"runtime translation to code failed")
	    (return () ()))
	  ;; should now compile the generated C code
	  ;; FIXME: we should have a runbuilt flavor.... (also in the
	  ;; runtime and the melt-module.mk)
	  (debug "translate_run_melt_expressions before compiling quicklybuilt flavor of basename=" basename)
	  (generate_flavored_melt_module basename basename '"quicklybuilt")
	  (debug "translate_run_melt_expressions after compiling quicklybuilt flavor of basename=" basename)
	  
	  (assert_msg "@$@translate_run_melt_expressions incomplete")
	  )))))

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

;; recursive internal utility to read melt expressions from files or lists or vectors or s-exprs
(defun read_melt_expressions (src rlist :long depth)
  (debug "read_melt_expressions src=" src " depth=" depth " rlist.len=" (list_length rlist))
  (assert_msg "check rlist" (is_list rlist))
  (assert_msg "check depth" (<i depth 100))
  (cond 
   ((null src)
    (return))
   ((is_string src)
    (informsg_strv "reading from MELT file source" src)
    (list_append2list rlist (read_file src)))
   ((is_list src)
    (foreach_in_list 
     (src)
     (curpair cursrc)
     (read_melt_expressions cursrc rlist (+i depth 1))))
   ((is_multiple src)
    (foreach_in_multiple
     (src)
     (cursrc :long six)
     (read_melt_expressions cursrc rlist (+i depth 1))))
   ((is_object src)
    (list_append rlist src))
   ((is_closure src)
    (let ( (xsrc (src rlist (+i depth 1)))
	   )
      (debug "read_melt_expressions xsrc=" xsrc " depth=" depth)
      (if (null xsrc) (return))
      (assert_msg "check xsrc" (or (is_a xsrc class_sexpr) (is_a xsrc class_symbol)))
      (list_append rlist xsrc)))
   (:else
    (error_strv () "invalid MELT expression to read, with discriminant" 
		(get_field :named_name (discrim src))))
   ))
    
;;;;;;;;;;;;;;;;
;;;;; utility function to translate to C some MELT sources
;;; modsrcname is the string for the module source file path; its
;;; basename should not contains any dots
(defun translate_to_c_module_melt_sources (sources modsrcname curenv)
  (debug  "translate_to_c_module_melt_sources sources=" sources " modsrcname=" modsrcname)
  (assert_msg "check curenv" (is_a curenv class_environment))
  (assert_msg "check modsrcname" (is_string modsrcname))
  (if (or (string_dynloaded_suffixed modsrcname)
	  (string_suffixed modsrcname ".melt")
	  (string_suffixed modsrcname ".c"))
      (errormsg_strv "invalid MELT source name - should not be suffixed"
		     modsrcname))
  (assert_msg "translate_to_c_module_melt_sources modsrcname not ended with MELT_DYNLOADED_SUFFIX"
	      (not (string_dynloaded_suffixed modsrcname)))
  (assert_msg "translate_to_c_module_melt_sources modulename not ended with .melt"
	      (not (string_suffixed modsrcname ".melt")))
  (assert_msg "translate_to_c_module_melt_sources modulename not ended with .c"
	      (not (string_suffixed modsrcname ".c")))
  (let ( (:long isvalidmodsrc 0)
	 (rlist (make_list discr_list)) 
	 )
    (code_chunk 
     setisvalidmodsrcch 
     #{ /* translate_to_c_module_melt_sources $SETISVALIDMODSRCCH */ {
     const char* modsrcstr = melt_string_str ((melt_ptr_t) $MODSRCNAME);
     const char* modsrcbase = modsrcstr ? (lbasename (modsrcstr)) : NULL;
     if (modsrcbase)
       $ISVALIDMODSRC =
       (strchr(modsrcbase,'.') == NULL) && (strchr(modsrcbase,'+') == NULL);
       } /* end translate_to_c_module_melt_sources $SETISVALIDMODSRCCH */
     }#)
    (if (not isvalidmodsrc)
	(progn
	  (debug "translate_to_c_module_melt_sources bad generated modsrcname=" modsrcname)
	  (errormsg_strv 
	   "invalid generated source name [basename should have no dot or plus]" 
	   modsrcname)
	  (return)
	  ))
    (read_melt_expressions sources rlist 0)
    (debug "after read translate_to_c_module_melt_sources rlist=" rlist)
    (assert_msg "check non empty rlist" (>i (list_length rlist) 0))
    (compile_list_sexpr rlist curenv modsrcname)
    (debug "translate_to_c_module_melt_sources done modsrcname=" modsrcname "\n")
    ))

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

(defun generate_gplv3plus_copyright_notice_c_comment (sbuf name)
  :doc #{Generate into stringbuffer $SBUF a C comment with GPLv3+
notice for file named $NAME.}#
  (assert_msg "check sbuf" (is_strbuf sbuf))
  (add2sbuf_strconst sbuf "/** Copyright (C) ")
  (let ( (:long year 0)
	 )
    (code_chunk  getyear
     #{ /*+ generate_gplv3plus_copyright_notice_c_comment $GETYEAR*/ {
        time_t $GETYEAR#_now = 0;
	struct tm* $GETYEAR#_tm = NULL;
        $YEAR = atol (__DATE__ + 7);
	time (&$GETYEAR#_now);
	if ($GETYEAR#_now > 0)
	   $GETYEAR#_tm = localtime (&$GETYEAR#_now);
        if ($GETYEAR#_tm) 
	   $YEAR = $GETYEAR#_tm->tm_year + 1900;
        } /*- $GETYEAR*/}#)
    (add2sbuf_longdec sbuf year)
    )
  (add2sbuf_strconst sbuf " Free Software Foundation, Inc.")
  (add2sbuf_indentnl sbuf 0)
  (add2sbuf_strconst sbuf "  This generated file ")
  (if (is_string name)
      (code_chunk 
       addbasename
       #{ /*$ADDBASENAME +*/
       meltgc_add_strbuf( (melt_ptr_t)($SBUF), 
			  lbasename (melt_string_str((melt_ptr_t)($NAME))));
       /*$ADDBASENAME -*/ }#)
   )
  (add2sbuf_strconst sbuf " is part of GCC.")
  (add2sbuf_indentnl sbuf 0)
  (add2sbuf_indentnl sbuf 0)
  (add2sbuf_strconst sbuf "                  [DON'T EDIT THIS GENERATED FILE]

    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/>.
**/")
  (add2sbuf_indentnl sbuf 0)
  (add2sbuf_indentnl sbuf 0)
)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(export_values 
 syntax_test_generator
 compile_list_sexpr
 generate_gplv3plus_copyright_notice_c_comment 
 get_code_buffer_limit
 put_code_buffer_limit
 translate_to_c_module_melt_sources
 translate_run_melt_expressions
 )

(export_class class_secondary_c_file)



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




;;; eof warmelt-outobj.melt