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

;; file warmelt-outobj.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008, 2009, 2010 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])
;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun outdeclinit_root (recv sbuf)
  (debug_msg recv "outdeclinit_root 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)
    )
  )
(install_method class_objinitelem output_c_code outpucod_objinielem)

(defun outcinitfill_root (recv implbuf ptrstr :long depth)
  (debug_msg recv "outcinitfill_root 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_msg recv "outcinitfill_root 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 "((void*)(MELT_PREDEF(")
     (add2sbuf_string implbuf (unsafe_get_field :named_name obpr))
     (add2sbuf_strconst implbuf ")))")
     )
   ( :else
     (debug_msg obpredef "bad obpredef")
     (assert_msg "invalid obpredef" ())
     )
   ))

;;; 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_msg recv "outcinitfill_objinitobject recv")
  (debug_msg ptrstr "outcinitfill_objinitobject 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_msg odata "outcinitfill_objinitobject 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_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 ") ")))
	  (output_c_code olocvar () sbuf (+i depth 1))
	  (add2sbuf_strconst sbuf " = (void*)&")
	  (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 (")
      (output_c_code odiscr () sbuf depth)
      (add2sbuf_strconst sbuf ") == OBMAG_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 "))->object_magic == OBMAG_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 ".obj_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_msg odobnum "outcinitfill_objinitobject unexpected 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
      )
    )
  )
(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_msg recv "outcinitpredef_objinitobject recv")
  (debug_msg ptrstr "outcinitpredef_objinitobject 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_msg oiopredef "outcinitpredef_objinitobject 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)
      ;; 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(predefinited,")
	 (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 "predefinited[")
	 (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_msg oiopredef "outcinitpredef_objinitobject unexpected 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_msg recv "outcinitfill_objinitmultiple recv")
  (debug_msg ptrstr "outcinitfill_objinitmultiple 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 " = (void*)&")
	  (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 ";")
    ))
(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_msg recv "outcinitfill_objinitclosure recv")
  (debug_msg ptrstr "outcinitfill_objinitclosure 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 " = (void*)&")
	  (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)
	  ))
    ))
(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_msg recv "outcinitfill_objinitroutine recv")
  (debug_msg ptrstr "outcinitfill_objinitroutine 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 " = (void*)&")
	  (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_msg ndatr "outcinitfill_objinitroutine ndatr")
	  (debug_msg dpro "outcinitfill_objinitroutine 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_msg ipro "outcinitfill_objinitroutine 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_msg recv "outcinitfill_objinitroutine (noipro) recv" )
	(add2sbuf_strconst sbuf "#warning no procedure in objinitroutine ")
	(add2sbuf_string sbuf cnam)
	(add2sbuf_indentnl sbuf 1)
	)
      )
    ))
(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_msg recv "outcinitfill_objinitstring recv")
  (debug_msg ptrstr "outcinitfill_objinitstring 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))
	 )
    (add2sbuf_strconst sbuf "/*inistring ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf 1)
    (if olocvar
	(progn
	  (output_c_code olocvar () sbuf 1)
	  (add2sbuf_strconst sbuf " = (void*)&")
	  (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 ".val, \"")
    (add2sbuf_cencstring sbuf (unsafe_get_field :oie_data recv))
    (add2sbuf_strconst sbuf "\", sizeof (") 
    (add2sbuf_string sbuf ptrstr)
    (add2sbuf_strconst sbuf "->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".val)-1);")
    (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_msg recv "outcinitfill_objinitboxedinteger recv")
  (debug_msg ptrstr "outcinitfill_objinitboxedinteger 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 " = (void*)&")
	  (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)
    ))
(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_msg recv "outcinitfill_objinitpair recv")
  (debug_msg ptrstr "outcinitfill_objinitpair 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 " = (void*)&")
	  (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)
    ))
(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_msg recv "outcinitfill_objinitlist recv")
  (debug_msg ptrstr "outcinitfill_objinitlist 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 " = (void*)&")
	  (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)
    )
  )
(install_method class_objinitlist output_c_initial_fill outcinitfill_objinitlist)
;;;;;;;;;;;;;;;;

(defun outpucod_anydiscr (any declbuf implbuf :long depth)
  ;(debug_msg any "outpucod_anydiscr any")
  (outcstring_err "* output_c_code unimplemented reciever discriminator ")
  (let ( (discr (discrim any)) ) (outstr_err (unsafe_get_field :named_name discr)))
  (outnewline_err)
  (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_msg anyr "outpucod_catchall_root anyr")
  (display_debug_message anyr "outpucod_catchall_root anyr")
  (outcstring_err "* output_c_code unimplemented reciever 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_locfile 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)
	)))

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

(definstance prevloc_container class_container)
(definstance previmplbuf_container class_container)

;; output the location & set the frame's location
(defun output_location (loc implbuf :long depth :cstring msg)
  (let ( (prevloc (unsafe_get_field :container_value prevloc_container))
	 (prevbuf (unsafe_get_field :container_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)
	      (return)
	      )
	  )
      )
    (Unsafe_put_fields  prevloc_container :container_value loc)
    (unsafe_put_fields  previmplbuf_container :container_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 ENABLE_CHECKING")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  const char* mcfr_flocs;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#endif")
    (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 callframe_melt_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 callframe_melt_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 "  void* 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
	  ;(debug_msg others "output_curframe_init others")
	  (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))
	     ))
	  )
      (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 framptr_
(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 " (framptr_->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 (framptr_->mcfr_varptr[ix])")
    (add2sbuf_indentnl implbuf 5)
    (add2sbuf_string implbuf (get_field :ctype_marker ctype_value))
    (add2sbuf_strconst implbuf " (framptr_->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 (framptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ") ")
	   (add2sbuf_string implbuf omarker)
	   (add2sbuf_strconst implbuf " (framptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ");")
	   (add2sbuf_indentnl implbuf 3)
	   )
	  ((is_a omarker class_named)
	   (add2sbuf_strconst implbuf "if (framptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ") ")
	   (add2sbuf_string implbuf (get_field :named_name omarker))
	   (add2sbuf_strconst implbuf " (framptr_->")
	   (add2sbuf_string implbuf oname)
	   (add2sbuf_strconst implbuf ");")
	   (add2sbuf_indentnl implbuf 3)
	   )
	  ))))
    ;;    (add2sbuf_indentnl implbuf 1)
    ))

;;; output the code for declaring and initializing the current frame 
(defun output_curframe_declstruct_init (declstruct rou implbuf)
					;(debug_msg rou "output_curframe_init rou")
  (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 call counter for debugging
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#if ENABLE_CHECKING")
    (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 "    *framptr_=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(xargdescr_ == MELTPAR_MARKGGC)) { /*mark for ggc*/")
	  (add2sbuf_indentnl implbuf 3)
	  (add2sbuf_strconst implbuf "int ix=0;")
	  (add2sbuf_indentnl implbuf 3)
	  (add2sbuf_strconst implbuf "framptr_ = (void*)firstargp_;")
	  (add2sbuf_indentnl implbuf 3)
	  (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 = closp_;")
	  (add2sbuf_indentnl implbuf 0)))
    (add2sbuf_strconst implbuf " meltfram__.mcfr_prev = (struct callframe_melt_st *) melt_topframe;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " melt_topframe = (struct callframe_melt_st *) &meltfram__;")
    (add2sbuf_indentnl implbuf 0)
    ))

;;; 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))
	 )
    ;(debug_msg prou "outpucod_procroutine 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 closp_,")
    (add2sbuf_strconst declbuf " melt_ptr_t firstargp_,")
    (add2sbuf_strconst declbuf " const char xargdescr_[],")
    (add2sbuf_strconst declbuf " union meltparam_un *xargtab_,")
    (add2sbuf_strconst declbuf " const char xresdescr_[],")
    (add2sbuf_strconst declbuf " union meltparam_un *xrestab_);")
    (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 closp_,")
    (add2sbuf_strconst implbuf " melt_ptr_t firstargp_,")
    (add2sbuf_strconst implbuf " const char xargdescr_[],")
    (add2sbuf_strconst implbuf " union meltparam_un *xargtab_,")
    (add2sbuf_indentnl implbuf 5)
    (add2sbuf_strconst implbuf " const char xresdescr_[],")
    (add2sbuf_strconst implbuf " union meltparam_un *xrestab_)")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (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)
    (debug_msg ogargs "outpucod_procroutine output ogargs")
    (assert_msg "check ogargs" (is_multiple_or_null ogargs))
    (multiple_every
     ogargs
     (lambda (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)
       ))
    (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
    ;(debug_msg obody "outpucod_procroutine output obody")
    (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)))))
    ;; 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_strconst implbuf "  melt_topframe = (struct callframe_melt_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 ");")
    (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)
    ))
(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 {")
  (multiple_every
   idatup
   (lambda (curdat :long curk) 
     ;(debug_msg curdat "output_curframe_cdat_struct curdat")
     (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 "}")
  )

;;; 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) 
   (debug_msg curpdat "outpucod_initialroutine curpdat inipredef")
   (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) 
   ;;(debug_msg curfil "outpucod_initialroutine curfil")
   (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)
  )




;; output code for the initial routine
(defun outpucod_initialroutine (pini declbuf implbuf :long depth)
  (assert_msg "check pini" (is_a pini class_initialroutineobj))
  (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)
    (add2sbuf_strconst declbuf "void* start_module_melt (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 predefinited[])")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define meltfram__  (*iniframp__)")
    (add2sbuf_indentnl implbuf 1)
    (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 " melt_assertmsg (\"check module initial frame\", iniframp__->mcfr_nbvar == /*minihash*/ -")
    (add2sbuf_longdec implbuf minihash)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf 1)
    (output_curframe_cdat_struct idatup implbuf)
    (add2sbuf_strconst implbuf " *cdat = NULL;")
    (add2sbuf_indentnl implbuf 0)
;;; 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)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "void* start_module_melt(void* modargp_) {")
    (add2sbuf_indentnl implbuf 0)
    ;;(debug_msg pini "outpucod_initialroutine pini")
    ;; generate the initial data structure
    ;;(debug_msg idatup "outpucod_initialroutine start idatup")
    ;;(debug_msg irfill "outpucod_initialroutine start irfill")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "char predefinited[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 callframe_melt_st*)&meltfram__)->mcfr_nbvar = /*minihash*/ -")
    (add2sbuf_longdec implbuf minihash)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "((struct callframe_melt_st*)&meltfram__)->mcfr_forwmarkrout = forward_or_mark_module_start_frame_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 1)
    (list_every
     iprolog
     (lambda (curprol)
       ;;(debug_msg curprol "outpucod_initialroutine 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(predefinited, 0, sizeof(predefinited));")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "initialize_module_meltdata_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " (&meltfram__, predefinited);")
    (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 256 is the size of each chunk...
	 (if (==i (%iraw bodix 256) 0)
	     (let ( (:long chunkix (+i chunkcount 1))
		    (newchunkbuf (make_strbuf discr_strbuf))
		    )
	       (setq chunkcount (+i chunkcount 1))
	       (list_append chunkbuflist newchunkbuf)
	       (setq chunkbuf newchunkbuf)))
	 ;; clear the previous location memoization
	 (unsafe_put_fields prevloc_container :container_value ())
	 (unsafe_put_fields previmplbuf_container :container_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)
	 ))
      ;; clear the previous location memoization
      (unsafe_put_fields prevloc_container :container_value ())
      (unsafe_put_fields previmplbuf_container :container_value ())
      (let ( (chunktup (list_to_multiple chunkbuflist discr_multiple)) 
	     )
	;; declare each chunk and call it
	(add2sbuf_indentnl declbuf 0)
	(add2sbuf_strconst declbuf "struct frame_start_module_melt_st;")
	(foreach_in_multiple
	 (chunktup)
	 (curchunk :long chunkix)
	 (add2sbuf_indentnl declbuf 0)
	 (add2sbuf_strconst declbuf "void MELT_MODULE_VISIBILITY ")
	 (add2sbuf_cident declbuf omodnam)
	 (add2sbuf_strconst declbuf "_initialmeltchunk_")
	 (add2sbuf_longdec declbuf chunkix)
	 (add2sbuf_strconst declbuf " (struct frame_start_module_melt_st*, char*);")
	 (add2sbuf_indentnl implbuf 1)
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "_initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf " (&meltfram__, predefinited);")
	 )
	(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 callframe_melt_st *) meltfram__.mcfr_prev;")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "/* popped initial frame */")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf " return ")
	(if oretval 
	    (output_c_code oretval declbuf implbuf 1)
	  (add2sbuf_strconst implbuf "/*noretval*/ NULL"))
	(add2sbuf_strconst implbuf ";")
	(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_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "} /* end start_module_melt */")
	(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 MELT_MODULE_VISIBILITY ")
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "_initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf " (struct frame_start_module_melt_st* meltframptr__, char predefinited[]) {")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#define meltfram__ (*meltframptr__)")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#undef meltcallcount")
	 (add2sbuf_indentnl implbuf 0)
	 (add2sbuf_strconst implbuf "#define meltcallcount 0L")
	 (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 ")
	 (add2sbuf_cident implbuf omodnam)
	 (add2sbuf_strconst implbuf "_initialmeltchunk_")
	 (add2sbuf_longdec implbuf chunkix)
	 (add2sbuf_strconst implbuf "*/")
	 (add2sbuf_indentnl implbuf 0)
	 )
	)
      )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst declbuf "static void forward_or_mark_module_start_frame_")
    (add2sbuf_cident declbuf omodnam)
    (add2sbuf_strconst declbuf " (struct callframe_melt_st* fp, int marking);")
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_strconst implbuf "static void forward_or_mark_module_start_frame_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " (struct callframe_melt_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* framptr_= (initial_frame_st*)fp;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " melt_assertmsg (\"check module frame\", framptr_->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 "for (ix = 0;  ix < ")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf "; ix++)  MELT_FORWARDED(framptr_->mcfr_varptr[ix]);")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf " return;")
    (add2sbuf_indentnl implbuf 1)
    (add2sbuf_strconst implbuf "} /*end forwarding*/")
    ;; output the marking
    (outpucod_marker pini implbuf)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /* end forward_or_mark_module_start_frame_")
    (add2sbuf_cident implbuf omodnam)
    (add2sbuf_strconst implbuf " */") 
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    ))
(install_method class_initialroutineobj output_c_code outpucod_initialroutine)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; output code for argument getter
(defun outpucod_getarg (garg declbuf implbuf :long depth)
  (assert_msg "check garg" (is_a garg class_objgetarg))
  ;(debug_msg garg "outpucod_getarg garg")
  (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) firstargp_;")
	  (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 (xargdescr_[")
	(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 " = (xargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].bp_aptr) ? (*(xargtab_[")
	      (add2sbuf_longdec implbuf (-i rkbind 1))
	      (add2sbuf_strconst implbuf "].bp_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 " = xargtab_[")
	    (add2sbuf_longdec implbuf (-i rkbind 1))
	    (add2sbuf_strconst implbuf "].")
	    (add2sbuf_string implbuf argf)
	    (add2sbuf_strconst implbuf ";")
	    )
	  )
	(add2sbuf_indentnl implbuf depth)
	))
    ;(debug_msg garg "outpucod_getarg done garg")
    ))
(install_method class_objgetarg output_c_code outpucod_getarg)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output code for objlocv
(defun outpucod_objlocv (locv declbuf implbuf :long depth)
  (assert_msg "check locv" (is_a locv class_objlocv))
  ;; (debug_msg locv "outpucod_objlocv locv")
  (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)))
    )
  )
(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 "])")
    ))
(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))
  (debug_msg ocnstv "outpucod_objconstv ocnstv")
  (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 "])")
    ))
(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 ";"))
      )))
  )
  



;; output code for objanyblock
(defun outpucod_objanyblock (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objanyblock))
  (debug_msg oblo "outpucod_objblock oblo")
  (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)
    )
  (debug_msg oblo "outpucod_objblock done oblo")
  )
(install_method class_objanyblock output_c_code outpucod_objanyblock)

;; output code for objmultiallocblock
(defun outpucod_objmultiallocblock (oblo declbuf implbuf :long depth)
  (debug_msg oblo "outpucod_objmultiallocblock oblo")
  (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")
    (debug_msg oallstruct "outpucod_objmultiallocblock oallstruct")
    (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)
     (debug_msg curstru "outpucod_objmultiallocblock curstru declare")
     (assert_msg "check curstru" (is_a curstru class_objinitelem))
     (add2sbuf_indentnl implbuf depthp1)
     (output_c_declinit curstru implbuf)
     )
    (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)
     (debug_msg curstru "outpucod_objmultiallocblock curstru initfill")
     (output_c_initial_fill curstru implbuf onameptr depthp1)
     (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)
    )
  (compile_warning "outpucod_objmultiallocblock could be incomplete")
  )
(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))
  (debug_msg obcit "outpucod_objciterblock obcit")
  (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")
    (multiple_every 
     obefore 
     (lambda (obef :long ix)
       (output_c_code obef declbuf implbuf (get_int boxdepthp1))
       ))
    (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")
    (multiple_every 
     oafter 
     (lambda (oaft :long ix)
       (output_c_code oaft declbuf implbuf (get_int boxdepthp1))
       ))
    (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)
    )
  )
(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)
    ))
(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))
  (debug_msg oblo "outpucod_objblock oblo")
  (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)
    )
  (debug_msg oblo "outpucod_objcommentedblock done oblo")
  )
(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))
  (debug_msg oblab "outpucod_objlabelinstr oblab")
  (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)
  (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))
  (debug_msg obgoto "outpucod_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)
)
(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)
    ))

;;; output code for objloop
(defun outpucod_objloop (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objloop))
  (debug_msg oblo "outpucod_objloop oblo")
  (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 ";")
	       (add2sbuf_indentnl implbuf depthp1))))))
    (add2sbuf_strconst implbuf "}")
    (add2sbuf_indentnl implbuf depth)
    )
  (debug_msg oblo "outpucod_objloop done oblo")
  )
(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))
  (debug_msg obxi "outpucod_objexit obxi")
  (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)    
    ))
(install_method class_objexit output_c_code outpucod_objexit)

;;; 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)))
	 )
    (debug_msg obcomp "outpucod_objcompute obcomp")
    (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)))))
	  ((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)))))
	  (:else
	   (output_c_code cexp declbuf implbuf (+i depth 1))
	   ))
    (add2sbuf_strconst implbuf ";")
    ))
(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))
  (debug_msg ocond "outpucod_objcond ocond")
  (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)
    ) 
  (debug_msg ocond "outpucod_objcond end ocond")
  )
(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))
  (debug_msg opif "outpucod_objcppif opif")
  (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)
    ))
(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))
  (debug_msg oisy "outpucod_objinternsymbol oisy")
  (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))
    ))
(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))
  (debug_msg oikw "outpucod_objinternkeyword oikw")
  (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))
    ))
(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))
  (debug_msg ogsy "outpucod_objgetnamedsymbol ogsy")
  (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 " = (void*) sy_")
      (add2sbuf_cident implbuf nsy)
      (add2sbuf_strconst implbuf "; }")
      (add2sbuf_indentnl implbuf depth)
      )))
(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))
  (debug_msg ogkw "outpucod_objgetnamedkeyword ogkw")
  (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 " = (void*) kw_")
      (add2sbuf_cident implbuf nkw)
      (add2sbuf_strconst implbuf "; }")
      (add2sbuf_indentnl implbuf depth)
      )))
(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))
  (debug_msg oapp "outpucod_objapply oapp")
  (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
	  (multiple_every
	   oargs
	   (lambda (curarg :long curank)
	     (debug_msg curarg "outputcod_objapply curarg")
	     (assert_msg "outputcod_objapply check curarg not objinstr" (not (is_a curarg class_objinstr)))
	     (if (>i curank 0)
		 (let ( (curctyp (get_ctype curarg ())) )
		   (debug_msg curctyp "outputcod_objapply curctyp")
		   (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 "bp_aptr = (melt_ptr_t*)NULL")) 
			 ( (is_a curarg class_objnil)
			   (add2sbuf_strconst implbuf "bp_aptr = /*nil*/(melt_ptr_t*)NULL"))
			 ( (== curctyp ctype_value)
			   (add2sbuf_strconst implbuf "bp_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))
		   ))))
	  ))
;;; 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,"))
    ;; 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)
    )
  )
(install_method class_objapply output_c_code outpucod_objapply)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; output a message send
(defun outpucod_objmsend (omsend declbuf implbuf :long depth)
  (debug_msg omsend "outpucod_objmsend omsend")
  (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)
	   (debug_msg curarg "outputcod_objmsend curarg")
	   (let ( (curctyp (get_ctype curarg ())) )
	     (debug_msg curctyp "outputcod_objmsend curctyp")
	     (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 "bp_aptr = (melt_ptr_t*)NULL")
		     ) 
		   ( (is_a curarg class_objnil)
		     (add2sbuf_strconst implbuf "bp_aptr = /*nil*/(melt_ptr_t*)NULL")
		     )
		   ( (== curctyp ctype_value)
		     (add2sbuf_strconst implbuf "bp_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 ";")
	     (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))
     (add2sbuf_strconst implbuf " = "))
    ;;
    (debug_msg orecv "outpucod_objmsend orecv")
    (debug_msg oloc "outpucod_objmsend oloc")
    (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)
    ))
(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))
  (debug_msg oapp "outpucod_objmultiapply oapp")
  (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
	  (multiple_every
	   oargs
	   (lambda (curarg :long curank)
	     (debug_msg curarg "outpucod_objmultiapply curarg")
	     (if (>i curank 0)
		 (let ( (curctyp (get_ctype curarg ())) )
		   (debug_msg curctyp "outpucod_objmultiapply curctyp")
		   (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 "bp_aptr = (melt_ptr_t*)NULL"))
		    ( (== curctyp ctype_value)
		      (add2sbuf_strconst implbuf "bp_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))
	  ))
    ;; output the initialization of restab
    (if (>i nbxres 0)
	(progn
	  (multiple_every
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curestyp (get_ctype cures ())) )
	       (debug_msg curestyp "outpucod_objmultiapply curestyp")
	       (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 "bp_aptr = (melt_ptr_t*)NULL"))
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_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)
    ))

(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))
  (debug_msg omsnd "outpucod_objmultimsend omsnd")
  (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
	  (multiple_every
	   oargs
	   (lambda (curarg :long curank)
	     (debug_msg curarg "outpucod_objmultimsend curarg")
	     (let ( (curctyp (get_ctype curarg ())) )
	       (debug_msg curctyp "outpucod_objmultimsend curctyp")
	       (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 "bp_aptr = (melt_ptr_t*)NULL"))
		( (== curctyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_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))
	  ))
    ;; output the initialization of restab
    (if (>i nbxres 0)
	(progn
	  (multiple_every
	   oxres
	   (lambda (cures :long curank)
	     (let ( (curestyp (get_ctype cures ())) )
	       (debug_msg curestyp "outpucod_objmultimsend curestyp")
	       (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 "bp_aptr = (melt_ptr_t*)NULL")
		  )
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_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 reciever
    (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)
    ))
(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))
  (debug_msg oclear "outpucod_objclear oclear")
  (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 ")
    )
  )
(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))
  (debug_msg oralob "outpucod_objrawallocobj oralob")
  (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 "\");")
    (list_every
     destlist
     (lambda (dst) 
       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
       (add2sbuf_strconst implbuf " =")))
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "newobj; };")
    (add2sbuf_indentnl implbuf depth)
    ))
(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))
  (debug_msg obnclo "outpucod_objnewclosure obnclo") 
  (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))
       (add2sbuf_strconst implbuf " =")))
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "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)
    ))
(install_method class_objnewclosure  output_c_code outpucod_objnewclosure)

;; output a touch
(defun outpucod_objtouch (otouch declbuf implbuf :long depth)
  (assert_msg "check oclear" (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 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))
  (debug_msg optup "outpucod_objputuple optup")
  (let ( (iloc (unsafe_get_field :obi_loc optup))
	 (otup (unsafe_get_field :oputu_tupled optup))
	 (ooff (unsafe_get_field :oputu_offset optup))
	 (oval (unsafe_get_field :oputu_value optup)) )
    (output_location iloc implbuf depth "putuple")
    (add2sbuf_strconst implbuf "/*putupl*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putupl checktup\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code otup declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))== OBMAG_MULTIPLE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putupl 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)
    )
  )
(install_method class_objputuple output_c_code outpucod_objputuple)

;;;;
(defun outpucod_objputpairhead (oput declbuf implbuf :long depth)
  (debug_msg oput "outpucod_objputpairhead oput")
  (let ( (oloc (unsafe_get_field :obi_loc oput))
	 (opair (get_field :oputp_pair oput))
	 (ohead (get_field :oputp_head oput))
	)
    (output_location oloc implbuf depth "putpairhead")
    (add2sbuf_strconst implbuf "/*putpairhead*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putpairhead /")
    (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 "))== OBMAG_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)
))
(install_method class_objputpairhead output_c_code outpucod_objputpairhead)

;;;;
(defun outpucod_objputpairtail (oput declbuf implbuf :long depth)
  (debug_msg oput "outpucod_objputpairtail oput")
  (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 "))== OBMAG_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)
))
(install_method class_objputpairtail output_c_code outpucod_objputpairtail)

;;;;
(defun outpucod_objputlist (oput declbuf implbuf :long depth)
  (debug_msg oput "outpucod_objputlist oput")
  (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 "))== OBMAG_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)
))
(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))
    (debug_msg ogsl "outpucod_objgetslot ogsl")
    (output_location oloc implbuf depth "getslot")
    (add2sbuf_strconst implbuf "{ melt_ptr_t slot=0;")
    (add2sbuf_indentnl implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "melt_object_get_field(slot,(melt_ptr_t)(")
    (output_c_code oobj declbuf implbuf depth)
    (add2sbuf_strconst implbuf "), ")
    (add2sbuf_longdec implbuf (get_int ofield))
    (add2sbuf_strconst implbuf ", \"")
    (add2sbuf_string implbuf (unsafe_get_field :named_name ofield))
    (add2sbuf_strconst implbuf "\");")
    (list_every
     destlist
     (lambda (dst)    
       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
       (add2sbuf_strconst implbuf " = ")))
    (add2sbuf_strconst implbuf "slot; };")
    (add2sbuf_indentnl implbuf depth)
    ))
(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))
  (debug_msg opslo "outpucod_objputslot opslo")
  (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 ")) == OBMAG_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)
    ))
(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))
  (debug_msg opclor "outpucod_objputclosurout opclor")
  (let ( (oloc (unsafe_get_field :obi_loc opclor))
	 (oclos (unsafe_get_field :opclor_clos opclor))
	 (orout (unsafe_get_field :opclor_rout opclor)) )
    (output_location oloc implbuf depth "putclosurout")
    (add2sbuf_strconst implbuf "/*putclosurout*/")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosrout checkclo\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "melt_assertmsg(\"putclosrout checkrout\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_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)
    )
  )
(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))
  (debug_msg opclov "outpucod_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 ")) == OBMAG_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)
    ))
(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))
  (debug_msg opclov "outpucod_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 ")) == OBMAG_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)
    ))
(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 "melt_assertmsg(\"putroutconst checkrout\", melt_magic_discr((melt_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_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)
    )
  )
(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 ")) == OBMAG_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)
    )
  )
(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 (!xrestab_ || !xresdescr_) goto labend_rout;")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "if (xresdescr_[")
    (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 (xrestab_[")
    (add2sbuf_longdec implbuf (get_int orank))
    (add2sbuf_strconst implbuf "].")
    (add2sbuf_string implbuf (unsafe_get_field :ctype_resfield octyp))
    (add2sbuf_strconst implbuf ") *(xrestab_[")
    (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)
    ))
(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)))))
(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)))
    (if (== otyp ctype_void)
	(progn
	  (add2sbuf_strconst implbuf ";}")
	  (add2sbuf_indentnl implbuf depth)))
    )
  )
(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)
  )


(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 "\"")
  )
(install_method discr_string output_c_code outpucod_string)

;(debug_msg discr_string "discr_string @@toplev warmmelt")


;;; 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 ")
  )
(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)) 
	 )
    (mapstring_every dic 
		     (lambda (nam ent) 
		       (assert_msg "check ent named" (is_a ent class_named))
		       (list_append entlist ent)))
    (let ( (rawtup (list_to_multiple entlist))
	   	   )
      (multiple_sort rawtup compare_named_alpha discr_multiple)
      )
    ))

(defun output_exported_offsets (modctx declbuf implbuf)
  (debug_msg modctx "output_exported_offsets modctx")
  (assert_msg "check modctx" (is_a modctx class_module_context))
  (let ( (sortedfields (sorted_named_dict_tuple
			(unsafe_get_field :mocx_expfieldict modctx)))
	 (sortedclasses (sorted_named_dict_tuple
			 (unsafe_get_field :mocx_expclassdict modctx)))
	 )
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "/* exported field offsets */")
    (multiple_every 
     sortedfields
     (lambda (fld :long ix)
       (assert_msg "check fld" (is_a fld class_field))
       (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_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "/* exported class lengths */")
    (multiple_every
     sortedclasses
     (lambda (cla :long ix)
       (assert_msg "check cla" (is_a cla class_class))
       (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 ";")
       ))
    (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
     ((meltobject_ptr_t) ($discr),
      melt_string_str(($base)), melt_string_str(($dir)), ($num))}#)

;; internal primitive if we want a single C file
(defprimitive wants_single_c_file () :long 
  #{ melt_wants_single_c_file () }#)

;;; 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))
  (if (wants_single_c_file) (return))
  (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 function to translate a macroexpanded list
(defun translate_macroexpanded_list (xlist modnamstr modctx ncx)
  (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))
  (let (
	(inienv (unsafe_get_field :mocx_initialenv modctx))
	(firstx (pair_head (list_first xlist)))
	(firstloc (if (is_a firstx class_source) (unsafe_get_field :loca_location firstx)))
	(iniproc (unsafe_get_field :nctx_initproc ncx))
	(declbuf (make_strbuf discr_strbuf))
	(implbuf (make_strbuf discr_strbuf)) 
	;; 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"
			  ))
	)
    (if (== inienv initial_environment)
	(add2sbuf_strconst declbuf "#define MELT_HAS_INITIAL_ENVIRONMENT 0")
      (add2sbuf_strconst declbuf "#define MELT_HAS_INITIAL_ENVIRONMENT 1")
      )
    (add2sbuf_indentnl declbuf 0)
    (list_prepend xlist ucmeb1)
    (debug_msg xlist "after macroexpansion compile_list_sexpr seq")
    (debug_msg inienv "after macroexpansion compile_list_sexpr inienv")
    (assert_msg "check iniproc" (is_a iniproc class_nrep_initproc))
    (assert_msg "check xlist" (is_list xlist))
    ;;
    (list_every
     xlist
     (lambda (sexp :long ix)
       (debug_msg sexp "compile_list_sexpr sexp")
       (let (
	     (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp)))
	     )
	 ;; special hack to handle toplevel comment 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_msg nexp "compile_list_sexpr nexp")    
	    (debug_msg nbind "compile_list_sexpr nbind")
	    (if (and (is_a nexp class_nrep)
		     (not (is_a nexp class_nrep_anyproc)))
		(let ( (wnexp (wrap_normal_let1 nexp nbind psloc)) )
		  (debug_msg wnexp "compile_list_sexpr wnexp")
		  (list_append (unsafe_get_field :ninit_topl iniproc) 
			       wnexp)
		  )))))))
    ;;
    (code_chunk 
     check_errors_after_normalization
     #{ 
     if (melt_error_counter>0) 
        melt_fatal_error ("MELT translation of %s halted after normalization: got %ld MELT errors", 
			  melt_string_str($MODNAMSTR), melt_error_counter) ;
     }#)
    (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_msg prolist "compile_list_sexpr prolist")  
      (assert_msg "check prolist" (is_list prolist))
      (list_every
       prolist
       (lambda (pro)
	 (assert_msg "check pro" (is_a pro class_nrep_anyproc))
	 (debug_msg pro "compile_list_sexpr pro")
	 (put_int countbox (+i (get_int countbox) 1))
	 (let ( (objpro (compile2obj_procedure pro modctx compicache (get_int countbox))) )
	   (debug_msg objpro "compile_list_sexpr objpro")
	   (debug_msg pro "compile_list_sexpr done pro")
	   (list_append objlist objpro)
	   ;;(debug_msg compicache "compile_list_sexpr compicache")
	   )))
      ;;
      (code_chunk 
       check_errors_after_compilation
       #{ /*$check_errors_after_compilation*/
       if (melt_error_counter>0) 
         melt_fatal_error ("MELT translation of %s halted after MELT compilation: got %ld MELT errors",
			   melt_string_str($modnamstr), melt_error_counter) ;
       }#)
      ;;
      (debug_msg objlist "compile_list_sexpr objlist")  
      (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))
	     )
	(assert_msg "check inipro" (is_a inipro class_nrep_initproc))
	(debug_msg procurmodenvlist "compile_list_sexpr procurmodenvlist")
	(let ( (iniobj (compile2obj_initproc inipro modctx inidata compicache procurmodenvlist importvalues)) )
	  (debug_msg iniobj "compile_list_sexpr iniobj")
;;;
	  (foreach_in_list
	   (objlist)
	   (pairel obel)
	   (debug_msg obel "compile_list_sexpr obel")
	   ;; we may 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_msg modnamstr "compile_list_sexpr final modnamstr") 
	  (debug_msg iniobj "compile_list_sexpr outputting iniobj")
	  (output_c_code iniobj declbuf implbuf 0)
	  (output_exported_offsets modctx declbuf implbuf)
	  (code_chunk outputcfile
		      #{ /* $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)
	  (if (not (wants_single_c_file))
	      (let ( (secfiles (get_field :mocx_filetuple modctx)) )
		(debug_msg secfiles "compile_list_sexpr secfiles")
		(foreach_in_multiple
		 (secfiles)
		 (curfil :long filix)
		 (debug_msg curfil "compile_list_sexpr curfil")
		 (if curfil
		     (progn
		       (assert_msg "check curfil" 
				   (is_a curfil class_secondary_c_file))
		       (assert_msg "check curfil index" 
				   (==i (get_int curfil) filix))
		       (let ( (secfilpath (get_field :secfil_path curfil))
			      (secdeclbuf (get_field :secfil_declbuf curfil))
			      (secimplbuf (get_field :secfil_implbuf curfil))
			      )
			 (code_chunk 
			  secfilout 
			  #{ /* $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)
			 ))
		   ))))))))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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_msg lsexp "\n\n\n*%*%* compile_list_sexpr lsexp" ) ;list of sexpr
  (debug_msg inienv "compile_list_sexpr inienv") ;initial environment
  (debug_msg modnamstr "compile_list_sexpr modnamstr") ;module name
  (assert_msg "check lsexp" (is_list lsexp))
  (assert_msg "check modnamstr" (is_string modnamstr))
  (assert_msg "check inienv" (is_a inienv class_environment))
  (let (
	(modctx (instance class_module_context
			  :mocx_modulename  (make_string_nakedbasename discr_string modnamstr)
			  :mocx_expfieldict (make_mapstring discr_map_strings 90)
			  :mocx_expclassdict (make_mapstring discr_map_strings 40)
			  :mocx_initialenv inienv
			  :mocx_funcount (make_integerbox discr_integer 0)
			  :mocx_filetuple ()
			  ))
	(ncx (create_normcontext modctx)) 
	)
    (debug_msg ncx "compile_list_sexpr initial ncx")
    (assert_msg "check ncx" (is_a ncx class_normalization_context))
    (let ( (xlist (macroexpand_toplevel_list lsexp inienv)) 
	   )
      (translate_macroexpanded_list xlist modnamstr modctx ncx)
))
	;;
      (code_chunk 
         check_errors_after_generation
	 #{ /*$check_errors_after_generation*/
	 if (melt_error_counter>0) 
	    melt_fatal_error ("MELT translation of %s halted after generation: got %ld MELT errors",  
			      melt_string_str($modnamstr), melt_error_counter);
	 }#)
  (message_dbg "ended compile_list_sexpr")
  )


(defprimitive melt_argument (:cstring nam) :cstring
  :doc #{Retrieve a MELT program argument as a string}#
  #{melt_argument($nam)}#)

(defun install_melt_mode (mode)
  :doc #{$INSTALL_MELT_MODE installs a new MELT mode, ie an instance of $CLASS_MELT_MODE.}#
  (assert_msg "check mode" (is_a mode class_melt_mode))
  (let ( (cmdict (get_field :sysdata_mode_dict initial_system_data))
	 (cnam (get_field :named_name mode))
	 )
    (debug_msg mode "install_melt_mode mode")
    (mapstring_putstr cmdict cnam mode)
))


;;;;


;;;;;;;;;;;;;;;;
;;;;; utility function to compile a file or a list of files
;;; files is a string or a list of strings (filenames to compile)
;;; modsrcname is the string for the module source file path
(defun compile_one_or_more_files (files modsrcname curenv)
  (assert_msg "check curenv" (is_a curenv class_environment))
  (assert_msg "check modsrcname" (is_string modsrcname))
  (let ( (rlist (make_list discr_list)) 
	 )
    (cond 
     ((is_string files) 
      (list_append2list rlist (read_file files)))
     ((is_list files)
      (foreach_in_list
       (files)
       (curpair curfile)
       (assert_msg "check curfile" (is_string curfile))
       (informsg_strv "reading from file" curfile)
       (let ( (curead (read_file curfile))
	      )
	 (debug_msg curead "compilefile_mode curead")
	 (assert_msg "check curead" (is_list_or_null curead))
	 (list_append2list rlist curead))))
     (:else
      (assert_msg "bad files - should be a list of filenames or a filename" ())
      ))
    (debug_msg rlist "after read compile_one_or_more_files rlist")
    (assert_msg "check non empty rlist" (>i (list_length rlist) 0))
    (compile_list_sexpr rlist curenv modsrcname)    
    ))

;;;;;;;;;;;;;;;;
;;;;;
(defun translatefile_docmd (cmd moduldata)
  (message_dbg "starting translatefile_docmd")
  (debug_msg cmd "start translatefile_docmd cmd")
  (debug_msg moduldata "start translatefile_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(inarg (make_stringconst discr_string (melt_argument "arg")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	)
    (debug_msg inarg "translatefile_docmd inarg")
    (debug_msg outarg "translatefile_docmd outarg")
    (debug_msg parmodenv "before read translatefile_docmd parmodenv")
    (debug_msg initial_environment "before read translatefile_docmd initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (basnam (cond
		    ( (is_string outarg) outarg)
		    ( (is_string inarg) (make_string_nakedbasename discr_string inarg))
		    (:else
		     (errormsg_plain "invalid translatefile mode")
		     (return)
		     )))
	   )
      (compile_one_or_more_files inarg basnam curenv)
      )))

(definstance translatefile_mode
  class_melt_mode
  :named_name '"translatefile"
  :meltmode_help '"MELT 'translatefile' mode: ARGUMENT= input file; OUTPUT= generated C file"
  :meltmode_fun translatefile_docmd
)
(install_melt_mode translatefile_mode)

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

(defun translatetomodule_docmd (cmd moduldata)
  (message_dbg "starting translatetomodule_docmd")
  (debug_msg cmd "start translatetomodule_docmd cmd")
  (debug_msg moduldata "start translatetomodule_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(inarg (make_stringconst discr_string (melt_argument "arg")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	)
    (debug_msg inarg "translatetomodule_docmd inarg")
    (debug_msg outarg "translatetomodule_docmd outarg")
    (debug_msg parmodenv "before read translatetomodule_docmd parmodenv")
    (debug_msg initial_environment "before read translatetomodule_docmd initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (basnam (cond
		    ( (is_string outarg) (make_string_nakedbasename discr_string outarg))
		    ( (is_string inarg) (make_string_nakedbasename discr_string inarg))
		    (:else
		     (errormsg_plain "invalid translatetomodule mode")
		     (return)
		     )))
	   (tmpsrcnam
	       (make_string_tempname_suffixed discr_string basnam ".c"))
	   (outnam (or outarg basnam))
	   (:long failremovesrc 0)
	   )
      (debug_msg basnam "translatetomodule_docmd basnam")
      (debug_msg tmpsrcnam "translatetomodule_docmd tmpsrcnam")
      (compile_one_or_more_files inarg tmpsrcnam curenv)
      (generate_melt_module tmpsrcnam outnam)
      (code_chunk 
       removetmpsrc
       #{
       $FAILREMOVESRC = (long) remove(melt_string_str((melt_ptr_t)$TMPSRCNAM))
       }#)
      (if failremovesrc
	  (warningmsg_strv "failed to remove temporary generated C file" 
			   tmpsrcnam))
      )))


(definstance translatetomodule_mode
  class_melt_mode
  :named_name '"translatetomodule"
  :meltmode_help '"MELT 'translatetomodule' mode: ARGUMENT= input file; OUTPUT= generated module *.so"
  :meltmode_fun translatetomodule_docmd
)
(install_melt_mode translatetomodule_mode)

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

(defun translatedebug_docmd (cmd moduldata)
  (message_dbg "starting translatedebug_docmd")
  (debug_msg cmd "start translatedebug_docmd cmd")
  (debug_msg moduldata "start translatedebug_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(inarg (make_stringconst discr_string (melt_argument "arg")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	)
    (debug_msg inarg "translatedebug_docmd inarg")
    (debug_msg outarg "translatedebug_docmd outarg")
    (debug_msg parmodenv "before read translatedebug_docmd parmodenv")
    (debug_msg initial_environment "before read translatedebug_docmd initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (basnam (cond
		    ( (is_string outarg) (make_string_nakedbasename discr_string outarg))
		    ( (is_string inarg) (make_string_nakedbasename discr_string inarg))
		    (:else
		     (errormsg_plain "invalid translatedebug mode")
		     (return)
		     )))
	   (srcnam
	    (let ( (srcnambuf (make_strbuf discr_strbuf)) )
	      (add2sbuf_string srcnambuf basnam)
	      (add2sbuf_strconst srcnambuf ".c")
	      (strbuf2string discr_string srcnambuf)))
	   (dbgmodulnam
	    (or outarg
		(let ( (dbgnambuf (make_strbuf discr_strbuf)) )
		  (add2sbuf_string dbgnambuf basnam)
		  (add2sbuf_strconst dbgnambuf ".n.so")
		  (strbuf2string discr_string dbgnambuf))))
	   )
      (debug_msg basnam "translatedebug_docmd basnam")
      (debug_msg srcnam "translatedebug_docmd srcnam")
      (compile_one_or_more_files inarg srcnam curenv)
      (debug_msg dbgmodulnam "translatedebug_docmd dbgmodulnam")
      (generate_melt_module srcnam dbgmodulnam)
      )))


(definstance translatedebug_mode
  class_melt_mode
  :named_name '"translatedebug"
  :meltmode_help '"MELT 'translatedebug' mode: ARGUMENT= input file;
OUTPUT= generated module *.so, also *.c and no MELT line
number. Useful for running gdb on the module."
  :meltmode_fun translatedebug_docmd
)
(install_melt_mode translatedebug_mode)

;;;;;;;;;;;;;;;;
;;;;;
(defun runfile_docmd (cmd moduldata)
  (debug_msg cmd "start runfile_docmd cmd")
  (debug_msg moduldata "start runfile_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(inarg (make_stringconst discr_string (melt_argument "arg")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	)
    (debug_msg parmodenv "before read runfile_mode parmodenv")
    (debug_msg initial_environment "before read runfile_mode initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (modulnam ()) 
	   (modsrcname
	    (cond
	     ( (is_string outarg) 
	       (setq modulnam (make_string_nakedbasename discr_string outarg))
	       outarg)
	     ( (is_string inarg) 
	       (setq modulnam (make_string_nakedbasename discr_string inarg))
	       (make_string_tempname_suffixed discr_string inarg ".c"))
	     (:else
	      (errormsg_plain "invalid runfile mode")
	      (return)
	      )))
	   )
      (compile_one_or_more_files inarg modsrcname curenv)
      (debug_msg modsrcname "after compilation runfile_mode modsrcname")
      (debug_msg modulnam "after compilation runfile_mode modulnam")
      ;; the new environment is silently discarded
      (ignore (load_melt_module curenv modulnam))
      )))
;;;;
(definstance runfile_mode
  class_melt_mode
  :named_name '"runfile"
  :meltmode_help '"MELT 'runfile' mode: ARGUMENT= input file; 
[OUTPUT=generated C]; translate and run an *.melt file."
  :meltmode_fun runfile_docmd
)
(install_melt_mode runfile_mode)

;;;;;;;;;;;;;;;;
;;;;;
(defun rundebug_docmd (cmd moduldata)
  (debug_msg cmd "start rundebug_docmd cmd")
  (debug_msg moduldata "start rundebug_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(inarg (make_stringconst discr_string (melt_argument "arg")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	)
    (debug_msg parmodenv "before read rundebug_mode parmodenv")
    (debug_msg initial_environment "before read rundebug_mode initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (modulnam ()) 
	   (modsrcname
	    (cond
	     ( (is_string outarg) 
	       (setq modulnam (make_string_nakedbasename discr_string outarg))
	       outarg)
	     ( (is_string inarg) 
	       (setq modulnam (make_string_nakedbasename discr_string inarg))
	       (make_string_tempname_suffixed discr_string inarg ".c"))
	     (:else
	      (errormsg_plain "invalid rundebug mode")
	      (return)
	      )))
	   (basnam (cond
		    ( (is_string outarg) (make_string_nakedbasename discr_string outarg))
		    ( (is_string inarg) (make_string_nakedbasename discr_string inarg))
		    (:else
		     (errormsg_plain "invalid rndebug mode")
		     (return)
		     )))
	   (dbgmodulnam 
	    (or outarg
		(let ( (dbgnambuf (make_strbuf discr_strbuf)) )
		  (add2sbuf_string dbgnambuf basnam)
		  (add2sbuf_strconst dbgnambuf ".n.so")
		  (strbuf2string discr_string dbgnambuf))))
	   )
      (compile_one_or_more_files inarg modsrcname curenv)
      (debug_msg modsrcname "after compilation rundebug_mode modsrcname")
      (debug_msg dbgmodulnam "before generate_debug_melt_module dbgmodulnam")
      (generate_debug_melt_module modsrcname dbgmodulnam)
      ;; the new environment is silently discarded
      (debug_msg dbgmodulnam "before load_debug_melt_module rundebug_mode dbgmodulnam")
      (ignore (load_debug_melt_module curenv dbgmodulnam))
      )))
;;;;
(definstance rundebug_mode
  class_melt_mode
  :named_name '"rundebug"
  :meltmode_help '"MELT 'rundebug' mode: ARGUMENT= input file; 
[OUTPUT=generated C]; translate and run an *.melt file in debug mode."
  :meltmode_fun rundebug_docmd
)
(install_melt_mode rundebug_mode)


;;;;;;;;;;;;;;;;
(defun translateinit_docmd (cmd moduldata)
  (debug_msg cmd "start translateinit_mode arg")
  (debug_msg moduldata "start translateinit_mode moduldata")
  (debug_msg initial_environment "before read translateinit_mode initial_environment")
  (let ( (rlist (make_list discr_list))
	 (:cstring progarg (melt_argument "arg"))
	 (:cstring progarglist (melt_argument "arglist"))
	 (inarg (cond ( progarg 
			(make_stringconst discr_string progarg))
		      ( progarglist
			 (split_string_comma discr_string progarglist)
			)
		      (:else
		       (errormsg_plain "invalid arg or arglist to translateinit mode")
		       (return))))
	 (outarg (make_stringconst discr_string (melt_argument "output")))
	 (basnam (cond
		  ( (is_string outarg) outarg)
		  ( (is_string inarg) (make_string_nakedbasename discr_string inarg))
		  (:else
		   (errormsg_plain "invalid translateinit mode")
		   (return)
		   )))
	 )
    (cond 
     ((is_string inarg) 
      (list_append2list rlist (read_file inarg)))
     ((is_list inarg)
      (list_every inarg 
		  (lambda (curarg)
		    (informsg_strv "reading from file" curarg)
		    (let ( (curead (read_file curarg))
			   )
		      (assert_msg "check rlist" (is_list rlist))
		      (assert_msg "check curead" (is_list_or_null curead))
		      (debug_msg curead "translateinit_mode curead")
		      (list_append2list rlist curead)))))
     )
    (debug_msg rlist "after read translateinit_mode rlist")
    (compile_list_sexpr rlist initial_environment basnam)
    (return)
    ))

;;;
(definstance translateinit_mode
  class_melt_mode
  :named_name '"translateinit"
  :meltmode_help '"MELT 'translateinit' mode: ARGUMENT= input file; OUTPUT= generated file"
  :meltmode_fun translateinit_docmd
)
(install_melt_mode translateinit_mode)




(defclass class_makedoc_info
  :super class_proped
  :fields (
	   ;; lists
	   mkdoc_primitives
	   mkdoc_functions
	   mkdoc_citerators
	   mkdoc_cmatchers
	   mkdoc_selectors
	   mkdoc_fields
	   mkdoc_classes
	   mkdoc_instances
	   mkdoc_macros
	   mkdoc_patmacros
	   ;; map from formal symbols to lists of definitions containing them
	   mkdoc_formaloccmap
	   ;; map from predefined symbol to definition
	   mkdoc_predefmap
	   ;; map from documented symbols to data or definition
	   mkdoc_docsymap
	   ;; map from documented classes to list of documented subclasses
	   mkdoc_subclassmap
	   )
)


(defun makedoc_scaninput (mdinfo arglist xlist)
  (let (
	(:long nbfil (list_length arglist))
	(:long xlistlen (list_length xlist))
	(docsymap (get_field :mkdoc_docsymap mdinfo))
	(formaloccmap (get_field :mkdoc_formaloccmap mdinfo))
	(add_docsym
	 (lambda (nam data)
	   (cond 
	    ( (and (!= (discrim nam) class_symbol)
		   (is_a nam class_named))
	      (setq nam (get_symbolstr (get_field :named_name nam))))
	    ( (is_string nam)
	      (setq nam (get_symbolstr nam)))
	    )
	   (assert_msg "check nam" (is_a nam class_symbol))
	   (mapobject_put docsymap
			  nam
			  data)))
	(fetch_docsym
	 (lambda (nam)
	   (cond 
	    ( (and (!= (discrim nam) class_symbol)
		   (is_a nam class_named))
	      (setq nam (get_symbolstr (get_field :named_name nam))))
	    ( (is_string nam)
	      (setq nam (get_symbolstr nam)))
	    )
	   (mapobject_get docsymap nam)))
	(add_formal_occ
	 (lambda (formbind def)
	   (assert_msg "check formbind" (is_a formbind class_formal_binding))
	   (assert_msg "check def" (is_a def class_source_definition))
	   (let ( (formsym (get_field :binder formbind)) 
		  (formocclist (mapobject_get formaloccmap formsym))
		  )
	     (if (null formocclist)
		 (progn
		   (setq formocclist (make_list discr_list))
		   (mapobject_put formaloccmap formsym formocclist)))
	     (list_append formocclist def)
	     )
	   ))
	)
    (code_chunk 
     informxlist
     #{ inform (UNKNOWN_LOCATION,
		"MELT makedoc [#%ld]: read and expanded %ld expressions from %ld files",
		melt_dbgcounter, $xlistlen, $nbfil); }#
      )
    (list_every
     xlist
     (lambda (curexp)
       (debug_msg curexp "makedoc_docmd curexp")
       (match 
	curexp 
;;;;;;;;;;;
;;; handle defclass
	(?(instance
	   class_source_defclass
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sobj_predef ?predef
	   :sclass_clabind ?(instance class_class_binding :cbind_class ?clas)
	   )
	  (debug_msg clas "makedoc_docmd defclass clas")
	  (assert_msg "check clas" (is_a clas class_class))
	  (if predef 
	      (mapobject_put (get_field :mkdoc_predefmap mdinfo) predef curexp))
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_classes mdinfo) curexp)
;;; add into :mkdoc_fields each own field
	  (foreach_in_multiple 
	   ((get_field :class_fields clas))
	   (curfld :long fldix)
	   (if (== (get_field :fld_ownclass curfld) clas)
	       (progn
		 (add_docsym (get_field :named_name curfld) curfld)
		 (list_append (get_field :mkdoc_fields mdinfo) curfld)))
	   )
;;; add into :mkdoc_subclassmap this class as subclass of each
;;; documented ancestor
	  (let ( (subclmap (get_field :mkdoc_subclassmap mdinfo)) )
	    (foreach_in_multiple 
	     ((get_field :class_ancestors clas))
	     (curanc :long ancix)
	     (let ( (curancsubcl (mapobject_get  (get_field :mkdoc_subclassmap mdinfo) curanc)) )
	       (if (null curancsubcl)
		   (progn
		     (setq curancsubcl (make_list discr_list))
		     (mapobject_put 
		      (get_field :mkdoc_subclassmap mdinfo) curanc curancsubcl)
		     ))
	       (list_append curancsubcl clas)
	       )
	     )))
;;;;
;;; handle defselector
	(?(instance
	   class_source_defselector
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sobj_predef ?predef
	   :sinst_class ?icla
	   )
	  (list_append (get_field :mkdoc_selectors mdinfo) curexp)
	  (add_docsym dnam curexp)
	  (if predef 
	      (mapobject_put (get_field :mkdoc_predefmap mdinfo) predef curexp))
	  )
;;; handle definstance
	(?(instance
	   class_source_definstance
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sobj_predef ?predef
	   :sinst_class ?icla
	   )
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_instances mdinfo) curexp)
	  (if predef 
	      (mapobject_put (get_field :mkdoc_predefmap mdinfo) predef curexp))
	  )
;;;;;;;
;;; handle defprimitive
	(?(instance
	   class_source_defprimitive
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sformal_args ?formargs
	   )
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_primitives mdinfo) curexp)
	  (foreach_in_multiple 
	   (formargs)
	   (curformb :long formix)
	   (add_formal_occ curformb curexp) ) 
	  )
;;;;;;;
;;; handle defun
	(?(instance
	   class_source_defun
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sformal_args ?formargs
	   )
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_functions mdinfo) curexp)
	  (foreach_in_multiple 
	   (formargs)
	   (curformb :long formix)
	   (add_formal_occ curformb curexp) ) 
	  )
;;;;;;;
;;; handle defciterator
	(?(instance
	   class_source_defciterator
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sformal_args ?formargs
	   )
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_citerators mdinfo) curexp)
	  (foreach_in_multiple 
	   (formargs)
	   (curformb :long formix)
	   (add_formal_occ curformb curexp) ) 
	  )
;;;;;;;
;;; handle defcmatcher
	(?(instance
	   class_source_defcmatcher
	   :sdef_name ?dnam
	   :sdef_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   :sformal_args ?formargs
	   )
	  (add_docsym dnam curexp)
	  (list_append (get_field :mkdoc_cmatchers mdinfo) curexp)
	  (foreach_in_multiple 
	   (formargs)
	   (curformb :long formix)
	   (add_formal_occ curformb curexp) ) 
	  )
;;;;;;;
;;; handle export_patmacro
	(?(instance
	   class_source_export_patmacro
	   :loca_location ?loc
	   :sexpmac_mname ?mname
	   :sexpmac_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   )
	  (add_docsym mname curexp)
	  (list_append (get_field :mkdoc_patmacros mdinfo) curexp)
	  )
;;;;;;;
;;; handle export_macro
	(?(instance
	   class_source_export_macro
	   :loca_location ?loc
	   :sexpmac_mname ?mname
	   :sexpmac_doc 
	   ?(instance class_sexpr 
		      :loca_location ?docloc
		      :sexp_contents ?docont)
	   )
	  (add_docsym mname curexp)
	  (list_append (get_field :mkdoc_macros mdinfo) curexp)
	  )
;;;;;;;
;;; catchall with warning
	(?(instance class_source_definition 
		    :sdef_name ?dnam
		    :sdef_doc 
		    ?(and ?doc 
			  ?(instance class_sexpr :loca_location ?loc :sexp_contents ?docl)))
	  (debug_msg dnam "makedoc_docmd dnam")
	  (debug_msg doc "makedoc_docmd doc")
	  (inform_strv loc "makedoc: got documented " (get_field :named_name dnam))
	  (warning_strv loc "makedoc: unimplemented for class " (get_field :named_name (discrim curexp)))
	  )
	)
       )))
  )


;;;;;;;;;;;;;;;;
;;;;; output the location, if any, of a definition
(defun makedoc_outdefloc (outb def :cstring prefstr)
  (assert_msg "check outb" (is_strbuf outb))
  (assert_msg "check def" (is_a def class_source_definition))
  (let ( (loc (get_field :loca_location def)) 
	 )
    (if (null loc) (return))
    (add2sbuf_strconst outb prefstr)
    (add2sbuf_texi_mixloc outb loc)
    (add2sbuf_strconst outb ".")
    (add2sbuf_indentnl outb 0)
    )
)

;;;; output a formal argument tuple
(defun makedoc_outformals (outb fargs :cstring prefstr)
  (assert_msg "check outb" (is_strbuf outb))
  (if (>i (multiple_length fargs) 0)
      (progn
	(add2sbuf_indentnl outb 0)
	(add2sbuf_strconst outb prefstr)
	(add2sbuf_indentnl outb 0)
	(add2sbuf_strconst outb "@multitable @columnfractions 0.05 0.15 0.4")
	(add2sbuf_indentnl outb 0)
	(add2sbuf_strconst outb "@headitem index @tab type @tab name")
	(foreach_in_multiple
	 (fargs)
	 (curfbind :long fix)
	 (assert_msg "check curfbind" (is_a curfbind class_formal_binding))
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "@item @i{")
	 (add2sbuf_longdec outb fix)
	 (add2sbuf_strconst outb "} @tab @slanted{")
	 (add2sbuf_string 
	  outb 
	  (get_field :named_name 
		     (get_field :ctype_keyword 
				(get_field :fbind_type curfbind))))
	 (let ( (argnam (get_field :named_name (get_field :binder curfbind))) )
	   (add2sbuf_strconst outb "} @tab @code{")
	   (add2sbuf_string outb argnam)
	   (add2sbuf_strconst outb "}")
	   (add2sbuf_indentnl outb 0)
	   (add2sbuf_strconst outb "@vindex ")
	   (add2sbuf_string outb argnam)
	   (add2sbuf_indentnl outb 0)
	   )
	 )
	(add2sbuf_indentnl outb 0)
	(add2sbuf_strconst outb "@end multitable")
	(add2sbuf_indentnl outb 0)
	)))


;;;; output the :doc sexpr
(defun makedoc_outdoc (outb doc :cstring prefstr)
  (assert_msg "check outb" (is_strbuf outb))
  (if (is_not_a doc class_sexpr) (return))
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb prefstr)
  ;; output the documentation
  (foreach_in_list
   ( (unsafe_get_field :sexp_contents doc) )
   (curpair curelem)
   (cond 
    ( (is_string curelem)
      (add2sbuf_string outb curelem))
    ( (is_a curelem class_named)
      (add2sbuf_strconst outb "@code{")
      (add2sbuf_string outb (unsafe_get_field :named_name curelem))
      (add2sbuf_strconst outb "}")
      )
    )
   )
  (add2sbuf_indentnl outb 0)
  ;; output the vindex entries
  (foreach_in_list
   ( (unsafe_get_field :sexp_contents doc) )
   (curpair curelem)
   (cond 
    ( (is_a curelem class_named)
      (add2sbuf_strconst outb "@vindex ")
      (add2sbuf_string outb (unsafe_get_field :named_name curelem))
      (add2sbuf_indentnl outb 0)
      )
    )
   )
  )

;;;;;;;;;;;;;;;;
;;;;; generate the documentation of a single class definition
(defun makedoc_outclassdef (mdinfo outb cladef :long claix)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (assert_msg "check cladef" (is_a cladef class_source_defclass))
  (let ( (cla (get_field :cbind_class (get_field :sclass_clabind cladef)))
	 (clancs (get_field :class_ancestors cla))
	 (clflds (get_field :class_fields cla))
	 (:long nbclanc (multiple_length clancs))
	 (:long nbclflds (multiple_length clflds))
	 (doc (get_field :sdef_doc cladef))
	 (subclalist (mapobject_get (get_field :mkdoc_subclassmap mdinfo) cla))
	 )
    (assert_msg "check cla" (is_a cla class_class))
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@subsection @var{")
    (add2sbuf_string outb (get_field :named_name cla))
    (add2sbuf_strconst outb "}")
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@vindex ")
    (add2sbuf_string outb (get_field :named_name cla))
    (add2sbuf_indentnl outb 0)
    (makedoc_outdefloc outb cladef "Class defined at ")
    ;; output the list of ancestors
    (if (>i nbclanc 0)
	(progn
	  (add2sbuf_indentnl outb 0)
	  (add2sbuf_strconst outb "@strong{")
	  (add2sbuf_longdec outb nbclanc)
	  (add2sbuf_strconst outb " ancestors:}")
	  (foreach_in_multiple
	   (clancs)
	   (curanc :long ancix)
	   (debug_msg curanc "makedoc_outclassdef curanc")
	   (assert_msg "check curanc" (is_a curanc class_class))
	   (add2sbuf_strconst outb " @code{")
	   (add2sbuf_string outb (get_field :named_name curanc))
	   (add2sbuf_strconst outb "}")
	   )
	  (add2sbuf_strconst outb ".")
	  (add2sbuf_indentnl outb 0)
	  ))
    ;; output the list of fields
    (if (>i nbclflds 0)
	(progn
	  (add2sbuf_indentnl outb 0)
	  (add2sbuf_strconst outb "@strong{")
	  (add2sbuf_longdec outb nbclflds)
	  (add2sbuf_strconst outb " fields:}")
	  (add2sbuf_indentnl outb 0)
	  (add2sbuf_strconst outb "@multitable @columnfractions 0.08 0.4 0.4")
	  (add2sbuf_indentnl outb 0)
	  (add2sbuf_strconst outb "@headitem offset @tab name @tab class")
	  (add2sbuf_indentnl outb 0)
	  (foreach_in_multiple
	   (clflds)
	   (curfld :long fldix)
	   (debug_msg curfld "makedoc_outclassdef curfld")
	   (assert_msg "check curfld" (is_a curfld class_field))
	   (add2sbuf_indentnl outb 0)
	   (add2sbuf_strconst outb "@item ")
	   (add2sbuf_longdec outb fldix)
	   (let ( (fldcla (get_field :fld_ownclass curfld)) )
	     (if (== fldcla cla)
		 (progn
		   (add2sbuf_strconst outb " @tab @strong{")
		   (add2sbuf_string outb (get_field :named_name curfld))
		   (add2sbuf_strconst outb "} @tab @emph{@code{")
		   (add2sbuf_string outb (get_field :named_name fldcla))
		   (add2sbuf_strconst outb "}}")
		   (add2sbuf_indentnl outb 0)
		   (add2sbuf_strconst outb "@vindex ")
		   (add2sbuf_string outb (get_field :named_name curfld))
		   (add2sbuf_indentnl outb 0)
		   )
	       (progn
		 (add2sbuf_strconst outb " @tab @emph{")
		 (add2sbuf_string outb (get_field :named_name curfld))
		 (add2sbuf_strconst outb "}")
		 (add2sbuf_indentnl outb 0)
		 (add2sbuf_strconst outb "@tab @code{")
		 (add2sbuf_string outb (get_field :named_name fldcla))
		 (add2sbuf_strconst outb "} ")
		 ))
	     (add2sbuf_indentnl outb 0)
	     )
	   )
	  (add2sbuf_strconst outb "@end multitable")
	  (add2sbuf_indentnl outb 0)
	  )
      )
    ;; output the list of documented subclasses, if any
    (if subclalist
	(let ( (rawsubclatup (list_to_multiple subclalist discr_multiple)) 
	       (sortedsubclatup (multiple_sort rawsubclatup
					       compare_named_alpha
					       discr_multiple))
	       (:long nbsubcla (multiple_length sortedsubclatup))
	       )
	  (add2sbuf_indentnl outb 0)
	  (debug_msg sortedsubclatup "makedoc_outclassdef sortedsubclatup")
	  (add2sbuf_strconst outb "@strong{")
	  (add2sbuf_longdec outb nbsubcla)
	  (add2sbuf_strconst outb " sub-classes:}")
	  (add2sbuf_indentnl outb 0)
	  (foreach_in_multiple
	   (sortedsubclatup)
	   (subcla :long sclix)
	   (if (>i sclix 0) 
	       (add2sbuf_strconst outb ","))
	   (add2sbuf_strconst outb " @code{")
	   (add2sbuf_string outb (get_field :named_name subcla))
	   (add2sbuf_strconst outb "}")
	   )
	  (add2sbuf_strconst outb ".")
	  (add2sbuf_indentnl outb 0) 
	  )
      )
    ;;; output the class description
    (makedoc_outdoc outb doc "@strong{class description:} ")
    (add2sbuf_indentnl outb 0) 
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;; generate the macro documentation
(defun makedoc_genmacro (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT macros")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT macros")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (maclist (get_field :mkdoc_macros mdinfo))
	 (unsortedmactuple (list_to_multiple maclist discr_multiple))
	 (sortedmactuple (multiple_sort unsortedmactuple
					compare_named_alpha
					discr_multiple))
	 )
    (add2sbuf_strconst outb "There are ")
    (add2sbuf_longdec outb (multiple_length sortedmactuple))
    (add2sbuf_strconst outb " documented macros.")
    (add2sbuf_indentnl outb 0)	
    (add2sbuf_indentnl outb 0)	
    (foreach_in_multiple
     (sortedmactuple)
     (curmac :long macix)
     (debug_msg curmac "makedoc_genmacro curmac")
     (assert_msg "check curmac" (is_a curmac class_source_export_macro))
     (let ( (mnam (get_field :named_name (get_field :sexpmac_mname curmac)))
	    (mloc (get_field :loca_location curmac))
	    (mdoc (get_field :sexpmac_doc curmac))
	    )
       (assert_msg "check mnam" (is_string mnam))
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@subsection @var{")
       (add2sbuf_string outb mnam)
       (add2sbuf_strconst outb "}")
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@vindex ")
       (add2sbuf_string outb mnam)
       (add2sbuf_indentnl outb 0)
       ;; don't use makedoc_outdefloc since this is not a definition!
       (if mloc
	   (progn
	     (add2sbuf_strconst outb "Macro defined at ")
	     (add2sbuf_texi_mixloc outb mloc)
	     (add2sbuf_strconst outb ".")
	     (add2sbuf_indentnl outb 0)
	     ))
       (makedoc_outdoc outb mdoc "@strong{macro description:} ")
       (add2sbuf_indentnl outb 0) 
       )
     )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;; generate the pattern macro documentation
(defun makedoc_genpatmacro (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT patterns")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT pattern macros")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (patmaclist (get_field :mkdoc_patmacros mdinfo))
	 (unsortedpatmactuple (list_to_multiple patmaclist discr_multiple))
	 (sortedpatmactuple (multiple_sort unsortedpatmactuple
					   compare_named_alpha
					   discr_multiple))
	 )
    (add2sbuf_strconst outb "There are ")
    (add2sbuf_longdec outb (multiple_length sortedpatmactuple))
    (add2sbuf_strconst outb " documented pattern-macros.")
    (add2sbuf_indentnl outb 0)		    	
    (foreach_in_multiple
     (sortedpatmactuple)
     (patmac :long pmacix)
     (debug_msg patmac "makedoc_genpatmacro patmac")
     (assert_msg "check patmac" (is_a patmac class_source_export_patmacro))
     (add2sbuf_indentnl outb 0)
     (let ( (mnam (get_field :named_name (get_field :sexpmac_mname patmac)))
	    (mloc (get_field :loca_location patmac))
	    (mdoc (get_field :sexpmac_doc patmac))
	    )
       (assert_msg "check mnam" (is_string mnam))
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@subsection @var{")
       (add2sbuf_string outb mnam)
       (add2sbuf_strconst outb "}")
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@vindex ")
       (add2sbuf_string outb mnam)
       (add2sbuf_indentnl outb 0)
       ;; don't use makedoc_outdefloc since this is not a definition!
       (if mloc
	   (progn
	     (add2sbuf_strconst outb "Pattern macro defined at ")
	     (add2sbuf_texi_mixloc outb mloc)
	     (add2sbuf_strconst outb ".")
	     (add2sbuf_indentnl outb 0)
	     ))
       (makedoc_outdoc outb mdoc "@strong{pattern macro description:} ")
       (add2sbuf_indentnl outb 0) 
       )
     )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;; generate the class documentation
(defun makedoc_genclass (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT classes")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT classes")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( 
	(quotedone '1)
	(quotedzero '0)
	(quotedminusone '-1)
	(unsortedclassestuple 
	 (list_to_multiple 
	  (get_field :mkdoc_classes mdinfo)
	  discr_multiple
	  (lambda (cldef)
	    (assert_msg "check cldef" (is_a cldef class_source_defclass))
	    (get_field :cbind_class (get_field :sclass_clabind cldef)))
	  ))
	(cmpclassdepthname
	 (lambda (cl0 cl1)
	   (assert_msg "check cl0" (is_a cl0 class_class))
	   (assert_msg "check cl1" (is_a cl1 class_class))
	   (let ( (cl0anc (unsafe_get_field :class_ancestors cl0))
		  (cl1anc (unsafe_get_field :class_ancestors cl1))
		  (:long nbcl0anc (multiple_length cl0anc))
		  (:long nbcl1anc (multiple_length cl1anc))
		  (cl0nam (unsafe_get_field :named_name cl0))
		  (cl1nam (unsafe_get_field :named_name cl1))
		  )
	     (cond 
	      ( (== cl0 cl1) 
		quotedzero)
	      ( (<i nbcl0anc nbcl1anc) 
		quotedminusone)
	      ( (>i nbcl0anc nbcl1anc) 
		quotedone)
	      ( (string< cl0nam cl1nam)
		quotedminusone)
	      ( (string> cl0nam cl1nam)
		quotedone)
	      (:else
;;; this should not happen
	       (assert_msg "cmpclassdepthname same name different classes!" ())
	       ())
	      )
	     )
	   )
	 )
	(cmpclassname
	 (lambda (cl0 cl1)
	   (assert_msg "check cl0" (is_a cl0 class_class))
	   (assert_msg "check cl1" (is_a cl1 class_class))
	   (let ( (cl0nam (unsafe_get_field :named_name cl0))
		  (cl1nam (unsafe_get_field :named_name cl1))
		  )
	     (cond
	      ( (== cl0 cl1) 
		quotedzero)
	      ( (string< cl0nam cl1nam)
		quotedminusone)
	      ( (string> cl0nam cl1nam)
		quotedone)
	      (:else
;;; this should not happen
	       (assert_msg "cmpclassname same name different classes!" ())
	       ())
	      )
	     )))
	(depthsortedclassestuple
	 (multiple_sort unsortedclassestuple cmpclassdepthname discr_multiple)
	 )
	(cmpclassdef
	 (lambda (cdf0 cdf1)
	   (assert_msg "check cdf0" (is_a cdf0 class_source_defclass))
	   (assert_msg "check cdf1" (is_a cdf1 class_source_defclass))
	   (compare_named_alpha (get_field :sdef_name cdf0) (get_field :sdef_name cdf1))
	   ))
	(alphasortedclassdeftuple
	 (multiple_sort 
	  (list_to_multiple (get_field :mkdoc_classes mdinfo)
			    discr_multiple)  
	  cmpclassdef discr_multiple)
	 )
	(:long depthix -1)
	(:long prevclaix -1)
	)
    (add2sbuf_strconst outb "Table of classes sorted by inheritance depth.")
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@table @strong")
    (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (depthsortedclassestuple)
     (curcla :long claix)
     (assert_msg "check curcla" (is_a curcla class_class))
     (let ( (:long nbanc (multiple_length (get_field :class_ancestors curcla))) )
       (if (<i depthix nbanc)
	   (progn
	     (setq depthix nbanc)
	     (setq prevclaix claix)
	     (add2sbuf_indentnl outb 0)
	     (add2sbuf_strconst outb "@item ")
	     (add2sbuf_longdec outb depthix)
	     (add2sbuf_strconst outb ": ")
	     (add2sbuf_indentnl outb 0))
	 (add2sbuf_strconst outb ",")
	 )
       (add2sbuf_strconst outb " @code{")
       (add2sbuf_string outb (get_field :named_name curcla))
       (add2sbuf_strconst outb "}")
       )
     ) 
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@end table")
    (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (alphasortedclassdeftuple)
     (curcladef :long claix)
     (assert_msg "check curcladef" (is_a curcladef class_source_defclass))
     (makedoc_outclassdef mdinfo outb curcladef claix)
     )
    )
  )


;;;;; output a primitive
(defun makedoc_outprimitivedef (mdinfo outb primdef :long primix)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (assert_msg "check primdef" (is_a primdef class_source_defprimitive))
  (let ( (pnam (get_field :sdef_name primdef)) 
	 (args (get_field :sformal_args primdef))
	 (type (get_field :sprim_type primdef))
	 (doc (get_field :sdef_doc primdef))
	 )
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@subsection @var{")
    (add2sbuf_string outb (get_field :named_name pnam))
    (add2sbuf_strconst outb "}")
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@vindex ")
    (add2sbuf_string outb (get_field :named_name pnam))
    (add2sbuf_indentnl outb 0)
    (makedoc_outdefloc outb primdef "Primitive defined at ")
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@strong{result type:} @code{")
    (add2sbuf_string outb (get_field :named_name (get_field :ctype_keyword type)))
    (add2sbuf_strconst outb "}")
    (add2sbuf_indentnl outb 0)
    (makedoc_outformals outb args "@strong{primitive formals:}")
    ;;; output the primitive description
    (makedoc_outdoc outb doc "@strong{primitive description:} ")
    (add2sbuf_indentnl outb 0) 
    ))

;;;;; generate the primitive documentation
(defun makedoc_genprimitive (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT primitives")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT primitives")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (rawprimlist (get_field :mkdoc_primitives mdinfo))
	 (rawprimtup (list_to_multiple rawprimlist discr_multiple))
	 (sortedprimtup (multiple_sort rawprimtup compare_named_alpha discr_multiple))
	 )
  (add2sbuf_strconst outb "There are ")
  (add2sbuf_longdec outb (multiple_length sortedprimtup))
  (add2sbuf_strconst outb " primitives.")
  (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (sortedprimtup)
     (curprimdef :long primix)
     (assert_msg "check curprim" (is_a curprimdef class_source_defprimitive))
     (makedoc_outprimitivedef mdinfo outb curprimdef primix)
     (add2sbuf_indentnl outb 0)
     )
    )
  )


;;;;;;;;;;;;;;;;
;;;;; output a function
(defun makedoc_outfunctiondef (mdinfo outb fundef :long primix)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (assert_msg "check fundef" (is_a fundef class_source_defun))
  (let ( (fnam (get_field :sdef_name fundef)) 
	 (args (get_field :sformal_args fundef))
	 (doc (get_field :sdef_doc fundef))
	 )
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@subsection @var{")
    (add2sbuf_string outb (get_field :named_name fnam))
    (add2sbuf_strconst outb "}")
    (add2sbuf_indentnl outb 0)
    (add2sbuf_strconst outb "@vindex ")
    (add2sbuf_string outb (get_field :named_name fnam))
    (add2sbuf_indentnl outb 0)
    (makedoc_outdefloc outb fundef "Function defined at ")
    (add2sbuf_indentnl outb 0)
    (makedoc_outformals outb args "@strong{Function formals:}")
    ;;; output the function description
    (makedoc_outdoc outb doc "@strong{Function description:} ")
    (add2sbuf_indentnl outb 0) 
    ))

;;;;; generate the function documentation
(defun makedoc_genfunction (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT functions")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT functions")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (rawfunlist (get_field :mkdoc_functions mdinfo))
	 (rawfuntup (list_to_multiple rawfunlist discr_multiple))
	 (sortedfuntup (multiple_sort rawfuntup compare_named_alpha discr_multiple))
	 )
    (add2sbuf_strconst outb "There are ")
    (add2sbuf_longdec outb (multiple_length sortedfuntup))
    (add2sbuf_strconst outb " functions.")
    (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (sortedfuntup)
     (curfundef :long funix)
     (assert_msg "check curfun" (is_a curfundef class_source_defun))
     (makedoc_outfunctiondef mdinfo outb curfundef funix)
     (add2sbuf_indentnl outb 0)
     )
    )
  )


;;;;;;;;;;;;;;;;
;;;;; generate the citerators documentation
(defun makedoc_genciterator (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT c-iterators")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT c-iterators")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (rawciterlist (get_field :mkdoc_citerators mdinfo))
	 (rawcitertup (list_to_multiple rawciterlist discr_multiple))
	 (sortedcitertup (multiple_sort rawcitertup compare_named_alpha discr_multiple))
	 )
    (debug_msg rawciterlist "makedoc_genciterator rawciterlist")
    (debug_msg sortedcitertup "makedoc_genciterator sortedcitertup")
    (add2sbuf_strconst outb "There are ")
    (add2sbuf_longdec outb (multiple_length sortedcitertup))
    (add2sbuf_strconst outb " c-iterators.")
    (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (sortedcitertup)
     (curciterdef :long citix)
     (debug_msg curciterdef "makedoc_genciterator curciter")
     (assert_msg "check curciterdef" (is_a curciterdef class_source_defciterator))
     (let ( (sloc (get_field :loca_location curciterdef) )
	    (snam (get_field :sdef_name curciterdef))
	    (sdoc (get_field :sdef_doc curciterdef))
	    (citer (get_field :sciterdef_citerator curciterdef))
	    )
       (assert_msg "check citer" (is_a citer class_citerator))
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@subsection @var{")
       (add2sbuf_string outb (get_field :named_name snam))
       (add2sbuf_strconst outb "}")
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@vindex ")
       (add2sbuf_string outb (get_field :named_name snam))
       (add2sbuf_indentnl outb 0)
       (makedoc_outdefloc outb curciterdef "C-iterator defined at ")
       (add2sbuf_indentnl outb 0)
       (makedoc_outformals outb (get_field :citer_start_formals citer) "@strong{c-iterator start formals:}")
       (add2sbuf_indentnl outb 0)
       (makedoc_outformals outb (get_field :citer_body_formals citer) "@strong{c-iterator body formals:}")
;;; output the function description
       (makedoc_outdoc outb sdoc "@strong{C-iterator description:} ")
       (add2sbuf_indentnl outb 0) 
       )
     )
    )
  (compile_warning "makedoc_genciterator incomplete")
  )


;;;;;;;;;;;;;;;;
;;;;; generate the cmatchers documentation
(defun makedoc_gencmatcher (mdinfo outb)
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outb" (is_strbuf outb))
  (add2sbuf_strconst outb "@node MELT c-matchers")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_strconst outb "@section MELT c-matchers")
  (add2sbuf_indentnl outb 0)
  (add2sbuf_indentnl outb 0)
  (let ( (rawcmatchlist (get_field :mkdoc_cmatchers mdinfo))
	 (rawcmatchtup (list_to_multiple rawcmatchlist discr_multiple))
	 (sortedcmatchtup (multiple_sort rawcmatchtup compare_named_alpha discr_multiple))
	 )
    (add2sbuf_strconst outb "There are ")
    (add2sbuf_longdec outb (multiple_length sortedcmatchtup))
    (add2sbuf_strconst outb " c-matchers.")
    (add2sbuf_indentnl outb 0)
    (foreach_in_multiple
     (sortedcmatchtup)
     (curcmatchdef :long citix)
     (debug_msg curcmatchdef "makedoc_gencmatcher curcmatch")
     (assert_msg "check curcmatchdef" (is_a curcmatchdef class_source_defcmatcher))
     (let (
	   (snam (get_field :sdef_name curcmatchdef))
	   (sdoc (get_field :sdef_doc curcmatchdef))
	   (cmatch (get_field :scmatdef_cmatcher curcmatchdef)) 
	   (cmin (get_field :amatch_in cmatch))
	   (cmabind (get_field :amatch_matchbind cmatch))
	   (cmout (get_field :amatch_out cmatch))
	   )
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@subsection @var{")
       (add2sbuf_string outb (get_field :named_name snam))
       (add2sbuf_strconst outb "}")
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@vindex ")
       (add2sbuf_string outb (get_field :named_name snam))
       (add2sbuf_indentnl outb 0)
       (makedoc_outdefloc outb curcmatchdef "C-matcher defined at ")
       (add2sbuf_indentnl outb 0)
       (add2sbuf_strconst outb "@strong{c-matcher matching formal:} @var{")
       (let ( (manamb (get_field :binder cmabind)) )
	 (add2sbuf_string outb (get_field :named_name manamb)) 
	 (add2sbuf_strconst outb "} - @slanted{")
	 (add2sbuf_string outb 
			  (get_field :named_name 
				     (get_field :ctype_keyword 
						(get_field :fbind_type cmabind))))
	 (add2sbuf_strconst outb "}")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "@vindex ")
	 (add2sbuf_string outb (get_field :named_name manamb)) 
	 (add2sbuf_indentnl outb 0)
	 )
       (makedoc_outformals outb cmin "@strong{c-matcher input formals:}")
       (add2sbuf_indentnl outb 0)
       (makedoc_outformals outb cmout "@strong{c-matcher output formals:}")
       (add2sbuf_indentnl outb 0)
       (makedoc_outdoc outb sdoc "@strong{C-matcher description:} ")
       (add2sbuf_indentnl outb 0)
       )
     )
    )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; makedoc - generate the output file
(compile_warning "should list selectors and document their formals if given")
(defun makedoc_genoutput (mdinfo outarg)
  (debug_msg mdinfo "makedoc_genoutput mdinfo")
  (assert_msg "check mdinfo" (is_a mdinfo class_makedoc_info))
  (assert_msg "check outarg" (is_string outarg))
  (let ( (outb (make_strbuf discr_strbuf)) 
	 )
	 (add2sbuf_strconst outb "@c **** makedoc generated file ")
	 (add2sbuf_string outb outarg)
	 (add2sbuf_indentnl outb 0)
	 (code_chunk 
	  outdat
	  #{time_t now = 0;
	  time (&now);
	  meltgc_add_out_raw ($outb, "@c **** generated ");
	  meltgc_add_out_raw ($outb, ctime (&now));
	  }#
	  )
	 (add2sbuf_strconst outb "@node MELT Programming Reference")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "@chapter MELT Programming Reference")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_indentnl outb 0)

	 ;; Some people suggested outputting an GFDL license. But
	 ;; others objected.  A paragraph of code doing that was
	 ;; removed after rev.160339 see
	 ;; http://gcc.gnu.org/ml/gcc-patches/2010-06/msg00767.html
	 ;; http://gcc.gnu.org/ml/gcc/2010-05/msg00674.html
	 ;; http://gcc.gnu.org/ml/gcc/2010-05/msg00125.html
	 ;; http://gcc.gnu.org/ml/gcc/2010-05/msg00749.html etc.

	 (add2sbuf_strconst outb "@menu")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT macros:: The MELT macros.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT patterns:: The MELT pattern macros.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT classes:: The MELT classes.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT primitives:: The MELT primitives.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT functions:: The MELT functions.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT c-iterators:: The MELT c-iterators.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "* MELT c-matchers:: The MELT c-matchers.")
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "@end menu")
	 (add2sbuf_indentnl outb 0)
	 ;; generate macro related stuff
	 (makedoc_genmacro mdinfo outb)
	 ;; generate patmacro related stuff
	 (makedoc_genpatmacro mdinfo outb)
	 ;; generate class related stuff
	 (makedoc_genclass mdinfo outb)
	 ;; generate primitive related stuff
	 (makedoc_genprimitive mdinfo outb)
	 ;; generate function related stuff
	 (makedoc_genfunction mdinfo outb)
	 ;; generate c-iterators related stuff
	 (makedoc_genciterator mdinfo outb)
	 ;; generate c-matchers related stuff
	 (makedoc_gencmatcher mdinfo outb)
	 (add2sbuf_indentnl outb 0)
	 (add2sbuf_strconst outb "@c **** end of makedoc generated file ")
	 (add2sbuf_string outb outarg)
	 (add2sbuf_indentnl outb 0)	   
	 (output_sbuf_strval outb outarg)
    )
)

;;;;;;;;;;;;;;;;
;;;;;
(defun makedoc_docmd (cmd moduldata)
  (debug_msg cmd "start makedoc_docmd cmd")
  (debug_msg moduldata "start makedoc_docmd moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	(arglist (split_string_comma discr_string (melt_argument "arglist")))
	(outarg (make_stringconst discr_string (melt_argument "output")))
	(rlist (make_list discr_list))
	(mdinfo 
	 (instance class_makedoc_info
		   :mkdoc_primitives (make_list discr_list)
		   :mkdoc_functions (make_list discr_list) 
		   :mkdoc_citerators (make_list discr_list)
		   :mkdoc_cmatchers (make_list discr_list)
		   :mkdoc_selectors (make_list discr_list)
		   :mkdoc_fields (make_list discr_list)
		   :mkdoc_classes (make_list discr_list) 
		   :mkdoc_instances (make_list discr_list)
		   :mkdoc_macros (make_list discr_list)
		   :mkdoc_patmacros (make_list discr_list)
		   :mkdoc_formaloccmap (make_mapobject discr_map_objects 1000)
		   :mkdoc_predefmap (make_mapobject discr_map_objects 200)
		   :mkdoc_docsymap (make_mapobject discr_map_objects 400)
		   :mkdoc_subclassmap (make_mapobject discr_map_objects 400)
		   ))
	)
    (debug_msg arglist "makedoc_docmd arglist")
    (debug_msg outarg "makedoc_docmd outarg")
    ;; read into rlist all the stuff
    (list_every 
     arglist 
     (lambda (curarg)
       (informsg_strv "reading from file" curarg)
       (let ( (curead (read_file curarg))
	      )
	 (assert_msg "check rlist" (is_list rlist))
	 (assert_msg "check curead" (is_list_or_null curead))
	 (debug_msg curead "makedoc_docmd curead")
	 (list_append2list rlist curead))))
    ;; macro expand it
    (let ( (xlist (macroexpand_toplevel_list rlist curenv)) 
	   )
      ;; scan the expanded input, and fill mdinfo appropriately.
      (makedoc_scaninput mdinfo arglist xlist)
      ;; generate the output
      (makedoc_genoutput mdinfo outarg)
      ))
  )

;;;
(definstance makedoc_mode
  class_melt_mode
  :named_name '"makedoc"
  :meltmode_help '"MELT 'makedoc' mode: ARGLIST= input file, ...; OUTPUT= generated file"
  :meltmode_fun makedoc_docmd
)
(install_melt_mode makedoc_mode)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(export_values 
 compile_list_sexpr
 install_melt_mode
 melt_argument
 )

;;if we don't export these the warmelt-outobj.0.d.so cannot be dlopened!
(export_class class_secondary_c_file class_makedoc_info)

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




;;; eof warmelt-outobj.melt