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

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

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


(debug_msg class_symbol "at start of warmelt-outobj Class_Symbol")
(debug_msg (fetch_predefined CLASS_SYMBOL) "start of warmelt-outobj predefined Class_Symbol")

(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 declbuf implbuf :long depth)
  (debug_msg recv "outcinitfill_root recv")
  (assert_msg "outcinitfill_root unimplemented catchall" ())
)
(install_method class_root output_c_initfill outcinitfill_root)



(defun outcinitpredef_root (recv declbuf implbuf :long depth)
  (debug_msg recv "outcinitfill_root recv")
  (return)
)
(install_method class_root output_c_initpredef outcinitpredef_root)

;;; output a predef
(defun output_predef (obpr implbuf :long depth)
  (cond 
   ( (is_integerbox obpr)
     (add2sbuf_strconst implbuf "basilys_globpredef(")
     (add2sbuf_longdec implbuf (get_int obpr))
     (add2sbuf_strconst implbuf ")")
     )
   ( (is_a obpr class_symbol)
     (add2sbuf_strconst implbuf "((void*)(BASILYSG(")
     (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 BASILYS_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)


(defun outcinitfill_objinitobject (recv sbuf)
  (assert_msg "outcinitfill_objinitobject check recv" (is_a recv class_objinitobject))
  (debug_msg recv "outcinitfill_objinitobject recv")
  (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))
    (let ( (odloc (unsafe_get_field :nrep_loc odata))
	   (odhash (unsafe_get_field :ninst_hash odata))
	   (odslots (unsafe_get_field :ninst_slots odata))
	   (odobnum (unsafe_get_field :ninst_objnum odata))
	   )
      (output_location odloc sbuf 1 "iniobj")
      (add2sbuf_strconst sbuf "/*iniobj ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "*/")
      (add2sbuf_indentnl sbuf 1)
      (if oiopredef
	  (progn
	    (add2sbuf_strconst sbuf "if (")
	    (output_predef oiopredef sbuf 1)
	    (add2sbuf_strconst sbuf " != (basilys_ptr_t)&cdat->")
	    (add2sbuf_string sbuf oname)
	    (add2sbuf_strconst sbuf ") {")
	    (add2sbuf_indentnl sbuf 2)
	    (add2sbuf_strconst sbuf "basilys_assertmsg(\"check.predef length ")
	    (output_predef oiopredef sbuf 2)
	    (add2sbuf_strconst sbuf "\", basilys_object_length((basilys_ptr_t)(")
	    (output_predef oiopredef sbuf 2)
	    (add2sbuf_strconst sbuf ")) >= ")
	    (add2sbuf_longdec sbuf (multiple_length odslots))
	    (add2sbuf_strconst sbuf ");")
	    (add2sbuf_indentnl sbuf 2)
	    (add2sbuf_strconst sbuf "};")
	    (add2sbuf_indentnl sbuf 1)
	    (output_c_code olocvar (the_null) sbuf 1)
	    (add2sbuf_strconst sbuf " = ")
	    (output_predef oiopredef sbuf 1)
	    (add2sbuf_strconst sbuf ";")
	    (add2sbuf_indentnl sbuf 1)
	    )
	(progn
	  ;; only set locvar if it was not set; hence already existing symbols are not recreated
	  (add2sbuf_strconst sbuf "if (!")
	  (output_c_code olocvar (the_null) sbuf 1)
	  (add2sbuf_strconst sbuf ") ")
	  (output_c_code olocvar (the_null) sbuf 2)
	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
	  (add2sbuf_string sbuf oname)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
      ;;generate the check that odiscr is non-null 
      (add2sbuf_strconst sbuf " basilys_assertmsg(\"iniobj checkdiscr ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "\", NULL != (void*)")
      (output_c_code odiscr (the_null) sbuf 1)
      (add2sbuf_strconst sbuf ");")
      (add2sbuf_indentnl sbuf 1)
      (add2sbuf_strconst sbuf " cdat->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".obj_class = (basilysobject_ptr_t)(")
      (output_c_code odiscr (the_null) sbuf 1)
      (add2sbuf_strconst sbuf ");")
      (add2sbuf_indentnl sbuf 1)
      (if odobnum
	  (progn
	    (add2sbuf_strconst sbuf " cdat->")
	    (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 1)
	    ))
      (add2sbuf_strconst sbuf " cdat->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".obj_hash = ")
      (add2sbuf_longdec sbuf (get_int odhash))
      (add2sbuf_strconst sbuf ";")
      (add2sbuf_indentnl sbuf 1)
      (add2sbuf_strconst sbuf " cdat->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf ".obj_len = ")
      (add2sbuf_longdec sbuf (multiple_length odslots))
      (add2sbuf_strconst sbuf ";")
      (add2sbuf_indentnl sbuf 0)
      ;;; (add2sbuf_strconst sbuf "#if BASILYS_HAS_OBJ_TAB_FIELDS")
      ;;; (add2sbuf_indentnl sbuf 1)
      ;;; (add2sbuf_strconst sbuf " cdat->")
      ;;; (add2sbuf_string sbuf oname)
      ;;; (add2sbuf_strconst sbuf ".obj_vartab = ")
      ;;; (add2sbuf_strconst sbuf " cdat->")
      ;;; (add2sbuf_string sbuf oname)
      ;;; (add2sbuf_strconst sbuf ".obj__tabfields;")
      ;;; (add2sbuf_indentnl sbuf 0)
      ;;; (add2sbuf_strconst sbuf "#endif /*BASILYS_HAS_OBJ_TAB_FIELDS*/")
      ;;; (add2sbuf_indentnl sbuf 1)
      (add2sbuf_strconst sbuf "basilys_object_set_serial((basilysobject_ptr_t) (&cdat->")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "));")
      (add2sbuf_indentnl sbuf 1)
      ;; output the fill
      )
    )
  )
(install_method class_objinitobject output_c_initfill outcinitfill_objinitobject)




(defun outcinitpredef_objinitobject (recv sbuf)
  (assert_msg "outcinitpredef_objinitobject check recv" (is_a recv class_objinitobject))
  (assert_msg "outcinitpredef_objinitobject check sbuf" (is_strbuf sbuf))
  (debug_msg recv "outcinitpredef_objinitobject recv")
  (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 (the_null)))
    (if (is_a oiopredef class_nrep_nil) (return (the_null)))
    (let ( (odloc (unsafe_get_field :nrep_loc odata))
	   )
      (output_location odloc sbuf 1 "inipredef")
      (add2sbuf_strconst sbuf "/*inipredef ")
      (add2sbuf_string sbuf oname)
      (add2sbuf_strconst sbuf "*/")
      (add2sbuf_indentnl sbuf 1)
      ;; we really initialize the predefined only if it was not initialized
      (cond
       ( (is_a oiopredef class_symbol)
	 (add2sbuf_strconst sbuf "if (!BASILYSG(")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ")) BASILYSG(")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ") = (basilys_ptr_t)&cdat->")
	 (add2sbuf_string sbuf oname)
	 (add2sbuf_strconst sbuf ";")
	 (add2sbuf_indentnl sbuf 1)
	 (add2sbuf_strconst sbuf "else {")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "BASILYSGIX(predefinited,")
	 (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
	 (add2sbuf_strconst sbuf ") = 1;")
	 (add2sbuf_indentnl sbuf 2)
	 (add2sbuf_strconst sbuf "fnotice(stderr, \"BASILYS: 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 (!basilys_globarr[")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf "]) basilys_globarr[")
	 (add2sbuf_longdec sbuf (get_int oiopredef))
	 (add2sbuf_strconst sbuf "] = (void*)&cdat->")
	 (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(\"BASILYS: 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 (the_null)))
       ( :else
	 (debug_msg oiopredef "outcinitpredef_objinitobject unexpected oiopredef")
	 (assert_msg "outcinitpredef_objinitobject unexpected oiopredef" ())
	 )))
    )
  )
  
(install_method class_objinitobject output_c_initpredef outcinitpredef_objinitobject)



(defun outdeclinit_objinitmultiple (recv sbuf)
  (add2sbuf_strconst sbuf " struct BASILYS_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)
  (assert_msg "outcinitfill_objinitmultiple check recv" (is_a recv class_objinitmultiple))
  (debug_msg recv "outcinitfill_objinitmultiple recv")
  (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 (the_null) sbuf 1)
	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (basilysobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".nbval = ")
    (add2sbuf_longdec sbuf (get_int recv))
    (add2sbuf_strconst sbuf ";")
    ))
(install_method class_objinitmultiple output_c_initfill outcinitfill_objinitmultiple)

(defun outdeclinit_objinitclosure (recv sbuf)
  (add2sbuf_strconst sbuf " struct BASILYS_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)
  (assert_msg "outcinitfill_objinitclosure check recv" (is_a recv class_objinitclosure))
  (debug_msg recv "outcinitfill_objinitclosure recv")
  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
	 (olocvar (unsafe_get_field :oie_locvar recv))
	 )
    (add2sbuf_strconst sbuf "/*iniclos ")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf "*/")
    (add2sbuf_indentnl sbuf 1)
    (if olocvar
	(progn
	  ; (add2sbuf_strconst sbuf "/*inicloslocvar*/ ")
	  (output_c_code olocvar (the_null) sbuf 1)
	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (basilysobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".nbval = ")
    (add2sbuf_longdec sbuf (get_int recv))
    (add2sbuf_strconst sbuf ";")
    (add2sbuf_indentnl sbuf 1)
    ))
(install_method class_objinitclosure output_c_initfill outcinitfill_objinitclosure)


(defun outdeclinit_objinitroutine (recv sbuf)
  (add2sbuf_strconst sbuf " struct BASILYS_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)
  (assert_msg "outcinitfill_objinitroutine check recv" (is_a recv class_objinitroutine))
  (debug_msg recv "outcinitfill_objinitroutine recv")
  (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 (the_null) sbuf 1)
	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (basilysobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " strncpy(cdat->")
    (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 "\",  BASILYS_ROUTDESCR_LEN - 1);")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst  sbuf " cdat->")
    (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 "*(basilysroutfun_t **) (cdat->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ".routaddr) = ")
	  (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_initfill outcinitfill_objinitroutine)

(defun outdeclinit_objinitstring (recv sbuf)
  (add2sbuf_strconst sbuf " struct BASILYS_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)
  (assert_msg "outcinitfill_objinitstring check recv" (is_a recv class_objinitstring))
  (debug_msg recv "outcinitfill_objinitstring recv")
  (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 (the_null) sbuf 1)
	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
	  (add2sbuf_string sbuf cnam)
	  (add2sbuf_strconst sbuf ";")
	  (add2sbuf_indentnl sbuf 1)
	  ))
    (add2sbuf_strconst sbuf " cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".discr = (basilysobject_ptr_t)(")
    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
    (add2sbuf_strconst sbuf ");")
    (add2sbuf_indentnl sbuf 1)
    (add2sbuf_strconst sbuf " strcpy(cdat->")
    (add2sbuf_string sbuf cnam)
    (add2sbuf_strconst sbuf ".val, \"")
    (add2sbuf_cencstring sbuf (unsafe_get_field :oie_data recv))
    (add2sbuf_strconst sbuf "\");")
    (add2sbuf_indentnl sbuf 1)
    ))
(install_method class_objinitstring output_c_initfill outcinitfill_objinitstring)


(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_anyrecv output_c_code outpucod_anydiscr)

(defun outpucod_null (nul declbuf implbuf :long depth)
  (add2sbuf_strconst implbuf "NULL")
)
(install_method discr_nullrecv 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")
  (displaydebugmsg 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)
	(add2sbuf_strconst implbuf "#line 0 ")
	(add2sbuf_strconst implbuf " \"")
	(cond ( (is_mixint loc) 
		(progn
		  (add2sbuf_string implbuf (mixint_val loc))
		  (add2sbuf_strconst implbuf ":")
		  (add2sbuf_longdec implbuf (get_int loc))))
	      ( (is_mixloc loc)
		(progn
		  (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 "\"")
	(add2sbuf_indentnl implbuf 0)
	(add2sbuf_strconst implbuf "#endif /*MELTGCC_NOLINENUMBERING*/")
	(add2sbuf_indentnl implbuf depth)
	)))

;; output the location & set the frame's location
(defun output_location (loc implbuf :long depth :cstring msg)
  (output_raw_location loc implbuf depth msg)
  (cond
   ( (is_mixint loc) 
     (add2sbuf_strconst implbuf "BASILYS_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 "\");")
     (add2sbuf_indentnl implbuf depth)
     )
   ( (is_mixloc loc)
     (add2sbuf_strconst implbuf "BASILYS_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 "\");")
     (add2sbuf_indentnl implbuf depth)
     )
   ))


;;; 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 "{ unsigned nbvar;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#if ENABLE_CHECKING")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  const char* flocs;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "#endif")
    (add2sbuf_indentnl dsbuf 0)
    ;; we declare a noinitialclos 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 "  struct basilysclosure_st *noinitialclos;")
      (add2sbuf_strconst dsbuf "  struct basilysclosure_st *clos;"))
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  struct excepth_basilys_st *exh;")
    (add2sbuf_indentnl dsbuf 0)
    (add2sbuf_strconst dsbuf "  struct callframe_basilys_st *prev;")
    (add2sbuf_indentnl dsbuf 0)
    (if (>i nbval 0) 
	(progn
	  (add2sbuf_strconst dsbuf "#define CURFRAM_NBVARPTR ")
	  (add2sbuf_longdec dsbuf nbval)
	  (add2sbuf_indentnl dsbuf 0)
	  (add2sbuf_strconst dsbuf "  void* 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 CURFRAM_NBVARPTR /*none*/0")
	(add2sbuf_indentnl dsbuf 0)))
    (if (>i nblong 0)
	(progn
	  (add2sbuf_strconst dsbuf "#define CURFRAM_NBVARNUM ")
	  (add2sbuf_longdec dsbuf nblong)
	  (add2sbuf_indentnl dsbuf 0)
	  (add2sbuf_strconst dsbuf "  long 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 CURFRAM_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 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 "#define callcount thiscallcounter__")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#else")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define callcount 0L")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#endif")
    (add2sbuf_indentnl implbuf 0)
    (declstruct rou implbuf)
    (add2sbuf_strconst implbuf "  curfram__;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "  memset(&curfram__, 0, sizeof(curfram__));")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " curfram__.nbvar = ")
    (add2sbuf_longdec implbuf nbval)
    (add2sbuf_strconst implbuf ";")
    (add2sbuf_indentnl implbuf 0)
    (if (not isinitial)
	(progn
	  (add2sbuf_strconst implbuf "  curfram__.clos = closp_;")
	  (add2sbuf_indentnl implbuf 0)))
    (add2sbuf_strconst implbuf " curfram__.prev = (struct callframe_basilys_st *) basilys_topframe;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " basilys_topframe = (struct callframe_basilys_st *) &curfram__;")
    (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 (make_stringconst discr_string "**")))
    ;; 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 "static basilys_ptr_t ")
    (add2sbuf_string declbuf onam)
    (add2sbuf_strconst declbuf "(basilysclosure_ptr_t closp_,")
    (add2sbuf_strconst declbuf " basilys_ptr_t firstargp_,")
    (add2sbuf_strconst declbuf " const char xargdescr_[],")
    (add2sbuf_strconst declbuf " union basilysparam_un *xargtab_,")
    (add2sbuf_strconst declbuf " const char xresdescr_[],")
    (add2sbuf_strconst declbuf " union basilysparam_un *xrestab_);")
    (add2sbuf_indentnl declbuf 0)
    ;; output the implementation
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "static basilys_ptr_t")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_string implbuf onam)
    (add2sbuf_strconst implbuf "(basilysclosure_ptr_t closp_,")
    (add2sbuf_strconst implbuf " basilys_ptr_t firstargp_,")
    (add2sbuf_strconst implbuf " const char xargdescr_[],")
    (add2sbuf_strconst implbuf " union basilysparam_un *xargtab_,")
    (add2sbuf_indentnl implbuf 5)
    (add2sbuf_strconst implbuf " const char xresdescr_[],")
    (add2sbuf_strconst implbuf " union basilysparam_un *xrestab_) {")
    (output_curframe_declstruct_init output_curframe_declstruct prou implbuf)
    (add2sbuf_strconst implbuf "basilys_trace_start(\"")
    (add2sbuf_string implbuf ofunam)
    (add2sbuf_strconst implbuf "\", callcount);")
    (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 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 "basilys_trace_end(\"")
    (add2sbuf_string implbuf ofunam)
    (add2sbuf_strconst implbuf "\", callcount);")
    (add2sbuf_strconst implbuf "  basilys_topframe = (struct callframe_basilys_st*) curfram__.prev;")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf " return (basilys_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 callcount")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef CURFRAM_NBVARNUM")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef CURFRAM_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*) basilysgc_allocate(sizeof(*cdat),0);")
  (add2sbuf_indentnl implbuf 1)
  (add2sbuf_strconst implbuf " basilys_prohibit_garbcoll = TRUE;")
  (add2sbuf_indentnl implbuf 1)
;;;
;;; generate the initial predef of cdat
  (add2sbuf_strconst implbuf "/*initial routine predef*/")
  (add2sbuf_indentnl implbuf 1)
  (multiple_every
   idatup
   (lambda (curpdat :long curk) 
     (debug_msg curpdat "outpucod_initialroutine curpdat inipredef")
     (output_c_initpredef curpdat implbuf)))
;;;
;;; generate the initial filling of cdat
  (add2sbuf_strconst implbuf "/*initial routine fill*/")
  (add2sbuf_indentnl implbuf 1)
  (multiple_every
   idatup
   (lambda (curfil :long curk) 
     (debug_msg curfil "outpucod_initialroutine curfil")
     (add2sbuf_indentnl implbuf 1)
     (output_c_initfill curfil implbuf)))
;;;;;;;
;;; initialize the variables
;;;
;;; clear the cdat for safety and renable GC
  (add2sbuf_strconst implbuf " cdat = NULL;")
  (add2sbuf_indentnl implbuf 0)
  (add2sbuf_strconst implbuf " basilys_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))
	) 
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_indentnl declbuf 0)
    (add2sbuf_strconst declbuf "void* start_module_basilys(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_cdata(initial_frame_st *iniframp__, char predefinited[])")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "{")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#define curfram__  (*iniframp__)")
    (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 curfram__")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /*end initialize_module_cdata*/")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "void* start_module_basilys(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[BGLOB__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 0)
    (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_cdata(&curfram__, predefinited);")
    (add2sbuf_indentnl implbuf 1)
;;; output the body
;;;
    (add2sbuf_strconst implbuf "/**initial routine body**/")
    (add2sbuf_indentnl implbuf 0)
    (let ( (ibody (unsafe_get_field :obrout_body pini)) 
	   )
      (debug_msg ibody "outpucod_initialroutine ibody")
      (list_every
       ibody
       (lambda (curbody)
	 (debug_msg curbody "outpucod_initialroutine curbody")
	 (if (and curbody (not (is_a curbody class_objpurevalue)))
	     (progn
	       (output_c_code curbody declbuf implbuf 1)
	       (add2sbuf_indentnl implbuf 1))))))
;;; 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:  basilys_topframe = (struct callframe_basilys_st *) curfram__.prev;")
    (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 callcount")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef CURFRAM_NBVARNUM")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "#undef CURFRAM_NBVARPTR")
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_indentnl implbuf 0)
    (add2sbuf_strconst implbuf "} /* end start_module_basilys */")
    (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 " = (basilys_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(basilys_discr((basilys_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 "*/ curfptr[")
       (add2sbuf_longdec implbuf (get_int loff))
       (add2sbuf_strconst implbuf "]") )
     ( (== ltyp ctype_long)
       (add2sbuf_strconst implbuf "/*_#")
       (add2sbuf_string implbuf lcnam)
       (add2sbuf_strconst implbuf "*/ curfnum[")
       (add2sbuf_longdec implbuf (get_int loff))
       (add2sbuf_strconst implbuf "]") )
     (:else
      (add2sbuf_strconst implbuf "/*_?*/ curfram__.")
      (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 "*/ curfclos->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 "*/ curfrout->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))
  (list_every 
   lis 
   (lambda (cur)
     (let ( (:long depth (get_int boxeddepth)) )
       (if (and cur (is_not_a cur class_objpurevalue))
	   (progn
	      (add2sbuf_indentnl implbuf depth)
	      (output_c_code cur declbuf implbuf depth)
	      (add2sbuf_strconst implbuf ";"))))))
)
	      
	   

;; output code for objblock
(defun outpucod_objblock (oblo declbuf implbuf :long depth)
  (assert_msg "check oblo" (is_a oblo class_objblock))
  (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 "/*block*/{")
    (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_objblock output_c_code outpucod_objblock)

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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_clonedsymbol))
  (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_clonedsymbol))
    (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_clonedsymbol))
    (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) basilysgc_intern_symbol((basilys_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) basilysgc_intern_keyword((basilys_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 "if (BASILYSG(INITIAL_SYSTEM_DATA)) { basilys_ptr_t sy_")
      (add2sbuf_cident implbuf nsy)
      (add2sbuf_strconst implbuf " = basilysgc_named_symbol(\"")
      (add2sbuf_string implbuf nsy)
      (add2sbuf_strconst implbuf "\", BASILYS_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 "if (BASILYSG(INITIAL_SYSTEM_DATA)) { basilys_ptr_t kw_")
      (add2sbuf_cident implbuf nkw)
      (add2sbuf_strconst implbuf " = basilysgc_named_keyword(\"")
      (add2sbuf_string implbuf nkw)
      (add2sbuf_strconst implbuf "\", BASILYS_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 basilysparam_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)))
	    ; (cbreak_msg "outputcod_objapply curarg")
	     (if (>i curank 0)
		 (let ( (curctyp (get_ctype curarg (the_null))) )
		   (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 = (basilys_ptr_t*)NULL")) 
			 ( (is_a curarg class_objnil)
			   (add2sbuf_strconst implbuf "bp_aptr = /*nil*/(basilys_ptr_t*)NULL"))
			 ( (== curctyp ctype_value)
			   (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 " basilys_apply ((basilysclosure_ptr_t)(")
    (output_c_code oclos declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), (basilys_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 basilysparam_un*)0,"))
    ;; no extra results
    (add2sbuf_strconst implbuf " \"\", (union basilysparam_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)
  (assert_msg "check omsend" (is_a omsend class_objmsend))
  (debug_msg omsend "outpucod_objmsend omsend")
  (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 basilysparam_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
	  (multiple_every
	   oargs
	   (lambda (curarg :long curank)
	     (debug_msg curarg "outputcod_objapply curarg")
		 (let ( (curctyp (get_ctype curarg (the_null))) )
		   (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 = (basilys_ptr_t*)NULL")
			   ) 
			 ( (is_a curarg class_objnil)
			   (add2sbuf_strconst implbuf "bp_aptr = /*nil*/(basilys_ptr_t*)NULL")
			   )
			 ( (== curctyp ctype_value)
			   (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 
     odest
     (lambda (curdest) 
       (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
       (add2sbuf_strconst implbuf " = ")))
    (add2sbuf_strconst implbuf "basilysgc_send((basilys_ptr_t)(")
    (output_c_code orecv declbuf implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "), (basilys_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 basilysparam_un*)0,"))
    ;; no extra results
    (add2sbuf_strconst implbuf " \"\", (union basilysparam_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 basilysparam_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 basilysparam_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 (the_null))) )
	     (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 (the_null))) )
		   (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 = (basilys_ptr_t*)NULL"))
		    ( (== curctyp ctype_value)
		      (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 (the_null))) )
	       (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 = (basilys_ptr_t*)NULL"))
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 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 " basilys_apply ((basilysclosure_ptr_t)(")
    (output_c_code oclos declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), (basilys_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 basilysparam_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 basilysparam_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 basilysparam_un argtab[")
	  (add2sbuf_longdec implbuf nbarg)
	  (add2sbuf_strconst implbuf "];")
	  (add2sbuf_indentnl implbuf (+i 1 depth))
	  ))
    (if (>i nbxres 0)
	(progn
	  (add2sbuf_strconst implbuf "union basilysparam_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 (the_null))) )
	       (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 (the_null))) )
	       (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 = (basilys_ptr_t*)NULL"))
		( (== curctyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 (the_null))) )
	       (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 = (basilys_ptr_t*)NULL")
		  )
		( (== curestyp ctype_value)
		  (add2sbuf_strconst implbuf "bp_aptr = (basilys_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 " basilysgc_send ((basilys_ptr_t)(")
    (output_c_code orecv declbuf implbuf (+i 1 depth))
    (add2sbuf_strconst implbuf "), ((basilys_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 basilysparam_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 basilysparam_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*/ { basilys_ptr_t newobj = 0;")
    (add2sbuf_indentnl implbuf (+i depth 1))
    (add2sbuf_strconst implbuf "basilys_raw_object_create(newobj,(basilys_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 "basilysgc_new_closure((basilysobject_ptr_t)(")
    (output_c_code odiscr declbuf implbuf (get_int boxdepthp1))
    (add2sbuf_strconst implbuf "), (basilysroutine_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 "basilysgc_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 "basilys_assertmsg(\"putupl checktup\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code otup declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))== OBMAG_MULTIPLE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putupl checkoff\", (")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">=0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< basilys_multiple_length((basilys_ptr_t)(")
    (output_c_code otup declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))));")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((basilysmultiple_ptr_t)(")
    (output_c_code otup declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (basilys_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_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 "{ basilys_ptr_t slot=0;")
       (add2sbuf_indentnl implbuf (+i 1 depth))
       (add2sbuf_strconst implbuf "basilys_object_get_field(slot,(basilys_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 "basilys_assertmsg(\"putslot checkobj")
    (if (is_a odata class_named)
	(progn
	  (add2sbuf_strconst implbuf " ")
	  (add2sbuf_string implbuf (unsafe_get_field :named_name odata))))
    (add2sbuf_strconst implbuf "\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code odata declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_OBJECT);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putslot checkoff\", (")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">=0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< basilys_object_length((basilys_ptr_t)(")
    (output_c_code odata declbuf implbuf depth)
    (add2sbuf_strconst implbuf "))));")
    (if (is_a ofield class_field)
	(progn
	  (add2sbuf_strconst implbuf "basilys_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 "((basilysobject_ptr_t)(")
	(output_c_code odata declbuf implbuf depth)
	(add2sbuf_strconst implbuf "))->obj_vartab[")
	(output_c_code ooff declbuf implbuf depth)
	(add2sbuf_strconst implbuf "] = (basilys_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 "basilys_assertmsg(\"putclosrout checkclo\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putclosrout checkrout\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((basilysclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->rout = (basilysroutine_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 "basilys_assertmsg(\"putclosv checkclo\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putclosv checkoff\", ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">= 0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< basilys_closure_size((basilys_ptr_t) (")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")));")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((basilysclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (basilys_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 "basilys_assertmsg(\"putclosvnotnull checkclo\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_CLOSURE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putclosvnotnull checknotnullval\", NULL != ")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putclosvnotnull checkoff\", ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf ">= 0 && ")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "< basilys_closure_size((basilys_ptr_t) (")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")));")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((basilysclosure_ptr_t)")
    (output_c_code oclos declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (basilys_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 "basilys_assertmsg(\"putroutconst checkrout\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_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 "((basilysroutine_ptr_t)")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (basilys_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 "basilys_assertmsg(\"putroutconstnotnull checkrout\", basilys_magic_discr((basilys_ptr_t)(")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")) == OBMAG_ROUTINE);")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "basilys_assertmsg(\"putroutconstnotnull notnullconst\", NULL != ")
    (output_c_code ocval declbuf implbuf depth)
    (add2sbuf_strconst implbuf ");")
    (add2sbuf_indentnl implbuf depth)
    (add2sbuf_strconst implbuf "((basilysroutine_ptr_t)")
    (output_c_code orout declbuf implbuf depth)
    (add2sbuf_strconst implbuf ")->tabval[")
    (output_c_code ooff declbuf implbuf depth)
    (add2sbuf_strconst implbuf "] = (basilys_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 (the_null)))
	  )
    (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 "basilys_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))
    (multiple_every
     cont
     (lambda (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)))
	 )
    (assert_msg "check cont" (is_multiple cont))
    (if (or (is_mixint oloc) (is_mixloc oloc))
	(output_raw_location oloc implbuf depth "expr")
	)
    (multiple_every
     cont
     (lambda (comp :long ix)
       (output_c_code comp declbuf implbuf (get_int boxdepthp1)))))
)
(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_verbatimstring))
  (add2sbuf_string implbuf vstr)
)


(install_method discr_verbatimstring 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 warmbasilys")


;;; 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)) 
	 (boxzero (make_integerbox discr_integer 0))
	 (boxneg (make_integerbox discr_integer -1))
	 (boxpos (make_integerbox discr_integer 1))
	 )
    (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))
	   (comp (lambda (e1 e2)
		   (let ( (n1 (unsafe_get_field :named_name e1))
			 (n2 (unsafe_get_field :named_name e2)) )
		     (cond ((string< n1 n2) boxneg)
			   ((string= n1 n2) boxzero)
			   (:else boxpos))
		   )))
	   )
      (multiple_sort rawtup comp discr_multiple)
    )
))

(defun output_exported_offsets (modctx declbuf implbuf)
  (debug_msg modctx "output_exported_offsets modctx")
  (assert_msg "check modctx" (is_a modctx class_modulcontext))
  (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 fieldoff__")
       (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 classlen__")
       (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)
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 (make_instance class_modulcontext
			       :mocx_modulename modnamstr
			       :mocx_expfieldict (make_mapstring discr_mapstrings 90)
			       :mocx_expclassdict (make_mapstring discr_mapstrings 40)
			       ))
	(ncx (create_normcontext modctx)) )
    (debug_msg ncx "compile_list_sexpr initial ncx")
    (assert_msg "check ncx" (is_a ncx class_normcontext))
    (let ( (xlist (macroexpand_toplevel_list lsexp inienv)) 
	   (firstx (pair_head (list_first xlist)))
	   (firstloc (if (is_a firstx class_src) (unsafe_get_field :src_loc 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 (make_instance class_src_update_current_module_environment_container
				  :src_loc firstloc
				  :sucme_comment (make_stringconst discr_string "at very start")
				  ))
	   )
      (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_src_comment)
	       (let ( (sloc (unsafe_get_field :src_loc 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)
		    )))))))
      (let ( (prolist (unsafe_get_field :nctx_proclist ncx)) 
	     (objlist (make_list discr_list))
	     (compicache (make_mapobject discr_mapobjects (+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")
	     )))
	(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")
	    (outnum_err "** warmelt generated " (list_length objlist) " routines into ")
	    (outstr_err modnamstr)
	    (outnewline_err)
	    (outcstring_err "** from ")
	    (out_cplugin_compiled_timestamp_err)
	    (outnewline_err)
	    (outcstring_err "** of checksum ")
	    (out_cplugin_md5_checksum_err)
	    (outnewline_err)
;;;
	    (list_every
	     objlist
	     (lambda (obel)
	       (debug_msg obel "compile_list_sexpr obel")
	       (output_c_code obel declbuf implbuf 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)
	    (output_cfile_decl_impl modnamstr declbuf implbuf)
	    (informsg_strv "warmelt generated module" modnamstr)
	    )))))
  (message_dbg "ended compile_list_sexpr")
  )



(defun install_initial_command (nam fun)
;  (messageval_dbg "install_initial_command @@ fun" fun)
;  (messageval_dbg "install_initial_command @@ nam" nam)
  (debug_msg fun "install_initial_command fun")
  (if (is_closure fun)
      (if (is_string nam)
	  (mapstring_putstr (unsafe_get_field :sysdata_cmd_fundict initial_system_data) 
			    nam fun))))
;;;;
(defun readseq_command (dispatcher arg secarg modata)
  (message_dbg "starting readseq")
  (debug_msg arg "start readseq_command")
  (let ( (rlist (read_file arg)) )
    (message_dbg "ending readseq")
    (debug_msg rlist "done readseq_command")
))

(install_initial_command  (stringconst2val discr_string "readseq") readseq_command)

;;;;

;;;;;
(defun compilefile_command (dispatcher arg secarg moduldata)
  (message_dbg "starting compilefile_command")
  (debug_msg arg "start compilefile_command arg")
  (debug_msg secarg "start compilefile_command secarg")
  (debug_msg moduldata "start compilefile_command moduldata")
  (let ( 
	(parmodenv (parent_module_environment))
	(curenv (if moduldata moduldata initial_environment))
	)
    (debug_msg parmodenv "before read compilefile_command parmodenv")
    (debug_msg initial_environment "before read compilefile_command initial_environment")
    (assert_msg "check curenv" (is_a curenv class_environment))
    (let ( (rlist (make_list discr_list))
	   (basnam (cond
		    ( (is_string secarg) secarg)
		    ( (is_string arg) (make_string_nakedbasename discr_string arg))
		    (:else
		     (errormsg_plain "explicit -fbasilys-secondarg should be specified with -fbasilys-arglist")
		     (return)
		     )))
	   )
      (cond 
       ((is_string arg) 
	(list_append2list rlist (read_file arg)))
       ((is_list arg)
	(list_every arg 
		    (lambda (curarg)
		      (informsg_strv "reading from file" curarg)
		      (let ( (curead (read_file curarg))
			     )
			(debug_msg curead "compilefile_command curead")
			(assert_msg "check rlist" (is_list rlist))
			(assert_msg "check curead" (is_list_or_null curead))
			(list_append2list rlist curead)))))
       )
      (debug_msg rlist "after read compilefile_command rlist")
      (debug_msg curenv "after read compilefile_command curenv")
      (compile_list_sexpr rlist curenv basnam)
      )))

(install_initial_command  (stringconst2val discr_string "compilefile") compilefile_command)

;;;;

(defun compileinit_command (dispatcher arg secarg moduldata)
  (message_dbg "starting compileinit_command")
  (debug_msg arg "start compileinit_command arg")
  (debug_msg secarg "start compileinit_command secarg")
  (debug_msg moduldata "start compileinit_command moduldata")
  (debug_msg initial_environment "before read compileinit_command initial_environment")
  (let ( (rlist (make_list discr_list))
	 (basnam (cond
		  ( (is_string secarg) secarg)
		  ( (is_string arg) (make_string_nakedbasename discr_string arg))
		  (:else
		   (errormsg_plain "explicit -fbasilys-secondarg should be specified with -fbasilys-arglist")
		   (return)
		   )))
	 )
    (cond 
     ((is_string arg) 
      (list_append2list rlist (read_file arg)))
     ((is_list arg)
      (list_every arg 
		  (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 "compileinit_command curead")
		      (list_append2list rlist curead)))))
     )
    (debug_msg rlist "after read compileinit_command rlist")
    ;;- (list_append 
    ;;-  rlist 
    ;;-  (make_instance
    ;;-   class_sexpr
    ;;-   :loca_location (make_mixint discr_mixedint
    ;;- 				  (make_stringconst discr_string "**builtin post_initialization**")
    ;;- 				  0)
    ;;-   :sexp_contents (list3 'post_initialization (the_null) basnam)))
    (compile_list_sexpr rlist initial_environment basnam)
    ))

(install_initial_command  (stringconst2val discr_string "compileinit") compileinit_command)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun showmdata_command (dispatcher arg secarg moduldata)
  (message_dbg "starting showmdata_command")
  (debug_msg moduldata "showmdata moduldata")
  (message_dbg "ending showmdata_command"))
(install_initial_command 
 (stringconst2val discr_string "showmdata") showmdata_command)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun showvar_command (dispatcher arg secarg moduldata)
  (let ( (sym (get_symbolstr arg)) 
	 (bind (find_env moduldata sym))
	 (val (if (is_a bind class_value_binding) 
		  (unsafe_get_field :vbind_value bind)))
	 )
    (debug_msg sym "showvar symbol")
    (debug_msg bind "showvar binding")
    (debug_msg val "showvar val")
    )
  )

(install_initial_command 
 (stringconst2val discr_string "showvar") showvar_command)

(export_values 
 install_initial_command
 compile_list_sexpr
)
;;;;;;;;;;;;;;;;

(debug_msg initial_system_data "toplevel initial_system_data")

(debug_msg class_symbol "at end of warmelt-outobj Class_Symbol")
(debug_msg (fetch_predefined CLASS_SYMBOL) "end of warmelt-outobj predefined Class_Symbol")

;;; eof warmelt-outobj.bysl