path: root/contrib/cold-basilys.lisp

;; file cold-basilys.lisp
;; -*- Lisp -*-
;; $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;    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, write to
;;    the Free Software Foundation, 51 Franklin Street, Fifth Floor,
;;    Boston, MA 02110-1301, USA.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; conventionally, our names contain underscores _ so the minus sign -
;; is only in CommonLisp names, in particular in names generated by
;; defstruct

(defvar this_compilation nil "the current compilation")

(warn "should add disc_super to class_discr")

(defun cpusec () (float (/ (get-internal-run-time) internal-time-units-per-second )))


;; program sbstract syntax tree 
(defstruct prog_src)

(defstruct (prog_if (:include prog_src)) 
  cond_expr then_expr else_expr)

(defstruct (prog_setq (:include prog_src))
  setq_var setq_expr)

(defstruct (prog_apply (:include prog_src))
  appl_fun appl_args)

(defstruct (prog_primitive (:include prog_src))
  prim_oper prim_args)

(defstruct (prog_chunk (:include prog_src)) ;chunks are used in primitive normalization
  chunk_args chunk_type)

(defstruct (prog_cstring (:include prog_src)) ;A C string constant
   c_str)

(defstruct (prog_quotesym (:include prog_src)) ;A quoted symbol or keyword
   qsym)

;;; the normalisation of a primitive requires its expansion as
;;; primitive calls ans primitive chunks

(defstruct (prog_let (:include prog_src))
  let_bindings let_body)

(defstruct (prog_send (:include prog_src))
  send_sel send_recv send_args)		

(defstruct (prog_unsafe_get_field (:include prog_src))
  uget_field uget_obj)

(defstruct (prog_unsafe_put_fields (:include prog_src))
  uput_obj uput_keys)

;; make an instance at runtime ; 
(defstruct (prog_make_instance (:include prog_src))
  mki_class mki_keys mki_classdef	;the classdef is internal, neede for normal forms
)	

(defstruct (prog_forever (:include prog_src))
  forever_bind forever_body)

(defstruct (prog_progn (:include prog_src))
  progn_body)

(defstruct (prog_exit (:include prog_src))
  exit_bind exit_body)

;internal representation of closed variable occurrence
(defstruct (prog_closedvar (:include prog_src))
  clv_var				;the closed variable
  clv_fun				;the closing function or lambda
  clv_bind				;the binding of the closed variable
)
			
; internal representation of closure allocation and fill
(defstruct (prog_makeclosure (:include prog_src))
  mkclos_fun				; the normalized function or lambda
  mkclos_closvars				; the list of closed variables
)

(defstruct (prog_def (:include prog_src)) 
  def_name)

(defstruct (prog_predef (:include prog_def))
  predef_rank)


;;prog_defun are for defun and for normalized anonymous lambda
(defstruct (prog_defun (:include prog_def)) ;defined name
  fun_lambda				    ;if this defun comes from a lambda otherwise nil
  fun_formals 				;list of formal arguments
  fun_body				;sequence of body
  fun_argbindings			;computed argument bindings
  fun_closvars				;computed closed variable list
  fun_constants				;computed list of quoted constants
)

;; prog_lambda are for source lambda
(defstruct (prog_lambda  (:include prog_src))
  lambda_formals			;list of formal arguments
  lambda_body 				;sequence for body
  lambda_argbindings 			;computed arguments bindings
  lambda_closvars			;computed closed variable list
  lambda_uniq				;unique number
)



;; prog_multicall are for multiple-binding of secondary results of calls
(defstruct (prog_multicall (:include prog_src))
  multicall_formals			;formal list of result variables
  multicall_call			;the call or send
  multicall_body			;body
)


(defstruct (prog_defvar (:include prog_predef)) ;@!not yet implemented
  var_expr)

(defstruct (prog_defclass  (:include prog_predef)) 
  class_super class_ownfields class_allfields)

(defstruct (prog_definstance  (:include prog_predef)) 
  inst_class inst_objnum inst_slots)

(defstruct (prog_defselector  (:include prog_definstance)) 
)



(defstruct instance_slot
  slot_field slot_value)

(defstruct (prog_field (:include prog_def))
  field_class field_offset)

(defstruct (prog_return (:include prog_src))
  retexprs)

(defstruct (prog_defprimitive (:include prog_def))
  primitive_formals primitive_type primitive_expansion)

;; for each variable occurrence, we need to know if the variable is
;; closed within the current function (or lambda) or bound inside

(defstruct cold_compenv
  serial		 ;serial number
  dict 					;dictionnary of bindings (by name)
  prev 					;link to previous environment
  for 					;optional function for which this env is made
)

;; flag to set to revert to default compenv printing
(defvar cold_compenv_defprint nil)

;; variable counting the number of compenv printing
(defvar count_compenv_print 0)

;; internal function to compute an hashcode for the dict of an environment
(defun envdicthash (env)
  (let ( (h (cold_compenv-serial env)) )
    (maphash (lambda (k v) 
	       (setq h (logand #xFFFFFFFF (+ h (* 8 (sxhash k)) (sxhash v)))))
	     (cold_compenv-dict env))
    h
))


;; internal hashtable to avoid printing manytimes the same environ
;; we map an environment to its envdicthash and its printing counter 
(defvar envprintdict (make-hash-table :size 1000))

;; for less verbose traces & debugs
(defmethod  print-object ((ob cold_compenv) st)
  (if cold_compenv_defprint 
      (call-next-method ob st)
    (progn
      (incf  count_compenv_print)
      (format st "CompEnv/~d<#~d>{~:@_"  (cold_compenv-serial ob) count_compenv_print)
      (let ( (curenv ob) 
	     (curdepth 0)
	     )
	(loop while curenv do
	      (finish-output st)
	      (let* ( (edict (cold_compenv-dict curenv))
		      (edicthash (envdicthash curenv))
		      (eprev (cold_compenv-prev curenv))
		      (efor  (cold_compenv-for curenv)) 
		      (eserial (cold_compenv-serial curenv))
		      (epri (gethash curenv envprintdict))
		      (eprihash (and epri (car epri)))
		      (epricnt (and epri (cdr epri)))
		      )
		(if (and 
		     (> curdepth 0) 
		     (eq eprihash edicthash)
		     (> epricnt (- count_compenv_print 64)))
		    (format st "!!*seecompenv/~d <<^^h~x#~d>>~:@_" eserial edicthash epricnt)
		  (let ( (newpri (cons edicthash count_compenv_print)) )
		    (setf  (gethash curenv envprintdict) newpri)
		    (format st "!compenv/~d [~d] <H~x>:~:@_"  
			    eserial (hash-table-count edict) (envdicthash curenv))
		    ;; display bindings in a sorted order
		    (let ( (revkeylist nil) )
		      (maphash (lambda (k v) 
				 (declare (ignore v))
				 (push k revkeylist)) edict)
		      (mapcar 
		       (lambda (k) (format st " *~a== ~S~:@_" k (gethash k edict)))
		       (sort revkeylist (lambda (k1 k2) (string< (symbol-name k1) (symbol-name k2))))
		       )
		      )
		    (if efor 
			(cond ( (prog_defun-p efor)
				(format st "!compenv/~d - for defun ~S~:@_" eserial (prog_defun-def_name efor)) )
			      ( (prog_lambda-p efor)
				(format st "compenv/~d - for lambda #~d~:@_" eserial (prog_lambda-lambda_uniq efor)) )
			      ( t
				(format st "compenv/~d - for? ~S~:_" eserial efor) ))
		      )
		    ))
		(if eprev 
		    (format st "!compenv/~d prev/~d: ~:@_" eserial (cold_compenv-serial eprev)))
		(setq curenv eprev)
		(incf curdepth)
		)
	      )
	)
      (format st "}~:@_")
      (finish-output st)
      )))
  
;; for less verbose traces & debugs
(defmethod  print-object ((ob prog_primitive) st)
  (let ( (poper (prog_primitive-prim_oper ob))
	 (pargs (prog_primitive-prim_args ob)) )
    (if (prog_defprimitive-p poper)
	(format st "#{Primitive/~a ~<~S~>}" (prog_defprimitive-def_name poper) pargs)
      (call-next-method ob st))))


;; for less verbose 
(defmethod print-object ((ob prog_closedvar) st)
  (let ( (cvar (prog_closedvar-clv_var ob))
	 (cfun (prog_closedvar-clv_fun ob))
	 (cbind (prog_closedvar-clv_bind ob)) )
  (format st "#{ProgClosedVar/~a" cvar)
  (if (prog_defun-p cfun) 
      (format st " cfun/~a" (prog_defun-def_name cfun))
      (format st " cfun=~S" cfun))
  (cond 
   ( (cold_class_binding-p cbind)
     (format st " cbind<class:~S>" (cold_class_binding-bname cbind)) )
   ( t
     (format st " cbind=~S" cbind)))
  (format st "}")
))
;; for less verbose traces
(defmethod print-object ((ob prog_defclass) st)
  (let ( (cname (prog_defclass-def_name ob))
	 (crank (prog_defclass-predef_rank ob))
	 (csuper (prog_defclass-class_super ob))
	 (cownf (prog_defclass-class_ownfields ob))
	 (callf (prog_defclass-class_allfields ob)) )
  (format st "#{ProgDefClass/~a" cname)
  (if crank (format st " predefrank/~S" crank))
  (if (prog_defclass-p csuper) 
      (format st " super:~a" (prog_defclass-def_name csuper))
    (format st " super=~S" csuper))
  (if cownf (format st " ownfl=~S" cownf))
  (if callf (format st " allfl=~S" callf))
  (format st "}")
))


(defmethod print-object ((ob prog_field) st)
  (let ( (fname (prog_field-def_name ob))
	 (fclass (prog_field-field_class ob))
	 (foff (prog_field-field_offset ob)) )
    (format st "#{ProgField/~a#~d" fname foff)
    (if (prog_defclass-p fclass)
	(format st " FldClass/~a" (prog_defclass-def_name fclass))
      (format st " FldClass=~S" fclass))
    (format st "}")    
    ))

(defmethod print-object ((ob prog_return) st)
  (let ( (re (prog_return-retexprs ob)) )
    (cond ( (and (consp re) (cdr re))
	    (progn
	      (format st "#{ProgReturn~d" (length re))
	      (mapc (lambda (x) (format st " ~S" x)) re)
	      (format st "}")
	      ))
	  ( (null re) (format st "{ProgReturn0}"))
	  ( t (format st "{Prog_RETURN ~S}" (car re))))
    ))


(defconstant cold_valid_types_list (list ':value ':long ':bool ':tree ':void  ':cstring	;and others
				    ))

;; test for valid cold type keyword
(defun cold_valid_type_keyword_p (k) 
  (member k cold_valid_types_list))


(defvar cold_compenv_serial_count 0)

(defconstant cold_first_env 
  (progn 
    (incf cold_compenv_serial_count) 
    (make-cold_compenv :serial cold_compenv_serial_count)))

(defun cold_fresh_env (parenv)
  (if parenv (or (cold_compenv-p parenv) 
		 (error "invalid parent env ~a ~%<::cold_fresh_env>" parenv)))
  (incf cold_compenv_serial_count)
  (make-cold_compenv :prev parenv 
		     :dict (make-hash-table :size 11)
		     :serial cold_compenv_serial_count))

(defstruct cold_any_binding
  bname)

(defstruct (cold_macro_binding (:include cold_any_binding))
  expanser)


;; for less verbose traces & debugs
(defmethod  print-object ((ob cold_macro_binding) st)
  (format st "#<!cold_macro_binding ~A!>" (cold_macro_binding-bname ob))
)

(defstruct (cold_class_binding (:include cold_any_binding))
  classdef 				;the prog_defclass
  classdata				;the obj_datainstance
)

(defstruct (cold_field_binding (:include cold_any_binding))
  fieldef				;the prog_field
  fieldata				;the obj_datainstance
)



(defstruct (cold_primitive_binding  (:include cold_any_binding))
  primitive
)

;; for less verbose traces & debugs
(defmethod  print-object ((ob cold_primitive_binding) st)
  (if (prog_defprimitive-p (cold_primitive_binding-primitive ob))
      (format st "#<!cold_primitive_binding ~A!>" (cold_primitive_binding-bname ob))
    (call-next-method ob st)
))




(defstruct (cold_function_binding  (:include cold_any_binding))
  function
  fclodata					;function closure data 
)

;; for less verbose traces & debugs
(defmethod  print-object ((ob cold_function_binding) st)
  (if (prog_defun-p (cold_function_binding-function ob))
      (format st "#<!cold_function_binding ~A!>" (cold_function_binding-bname ob))
    (call-next-method ob st)
))

(defstruct (cold_typed_binding (:include cold_any_binding))
  type)

(defstruct (cold_instance_binding (:include cold_typed_binding))
  instancedef instancedata)

(defstruct (cold_selector_binding (:include cold_typed_binding))
  selectordef selectordata)

(defstruct (cold_let_binding  (:include cold_typed_binding))
  expr 
)

(defstruct (cold_value_binding  (:include cold_typed_binding))
  val 
  compilrole 				;optional compiler role, eg SELECTOR 
)
;;; maybe we need a cold_fieldvalue_binding which is a
;;; cold_value_binding and also knows about the field at compile time
;;; and likewise for classes and instances and selectors

(defstruct (cold_code_binding  (:include cold_typed_binding))
  code 
)


(defstruct (cold_formal_binding (:include cold_typed_binding))
  rank 
  )


(defstruct (cold_cdata_binding (:include cold_typed_binding))
  cdata)

(defstruct (cold_forever_binding (:include cold_typed_binding))
  uniq					;unique gensymed id
)

(defstruct (cold_obforever_binding (:include cold_forever_binding))
  lobvar					;forever objvar
)


;; for ease of trace & debugging
(defmethod print-object ((ob cold_let_binding) st)
  (let ( (bna (cold_any_binding-bname ob))
	 (bty (cold_typed_binding-type ob))
	 (bex (cold_let_binding-expr ob)) )
  (format st "{LetBi[~a" bna)
  (if bty (format st " :~s" bty))
  (format st " := ~S ]}" bex)
))


;; convert a keyword :AA to symbol AA
(defun keyword2symbol (k) 
  (if (keywordp k) (intern (symbol-name k)) k))


;; function to find a binding
(defun cold_find_binding (nam env)
  (and (cold_compenv-p env)
       (let ((dict (cold_compenv-dict env)))
	 (or (and 
	      (hash-table-p dict)
	      (gethash nam dict))
	     (cold_find_binding nam (cold_compenv-prev env))
	 ))
       ))

;;; function to find a binding and also return the reversed list of enclosing functions
(defun cold_enclosed_find_binding (nam env)
  (labels (
	   (recscan (nam env lifun)
		    (and (cold_compenv-p env)
			 (let ( (dict (cold_compenv-dict env))
				(envprev  (cold_compenv-prev env))
				(newlifun 
				 (let ( (forf (cold_compenv-for env)) )
				   (if forf (cons forf lifun) lifun))) )
			   (if (hash-table-p dict)
			       (let ( (bi (gethash nam dict)) )
				 (if bi (values bi lifun)
				   (recscan nam envprev newlifun)))
			     (recscan nam envprev newlifun)
			     ))))
	   )
    (recscan nam env ())))
		    
      


(defun cold_tested_find_binding (nam env test)
  (and (cold_compenv-p env)
       (let ((dict (cold_compenv-dict env)))
	 (or (and 
	      (hash-table-p dict)
	      (gethash nam dict))
	     (and 
	      (funcall test env)
	      (cold_find_binding nam (cold_compenv-prev env))
	 )))))

	      
  
(defun cold_put_binding (cbind env)
  (assert (cold_compenv-p env))
  (or (cold_any_binding-p cbind)
      (error "bad cold binding ~S to put in env ~S~%<::cold_put_binding>" cbind env))
  (let ( (bnam (cold_any_binding-bname cbind))
	 (dict (cold_compenv-dict env))) 
    (or (hash-table-p dict) 
	(progn 
	  (setq dict (make-hash-table :size 13))
	  (setf (cold_compenv-dict env) dict)
	  ))
    (setf (gethash bnam dict) cbind)
    )
)

(defun cold_define_macro (nam expans env)
  (let ( (mbind (make-cold_macro_binding 
		 :bname nam :expanser expans)) )
    (cold_put_binding mbind env))
)


(defun cold_macroexpand (sexpr env)
  (flet 
   ( (makeapply 
      (f args)
      (assert (not (keywordp f)) 
	      (f sexpr) 
	      "invalid fun f=~S to makeapply in macroexpand sexpr=~S" f sexpr)
      (make-prog_apply :appl_fun f :appl_args args)) 
     (makeprim 
      (p args)
      (make-prog_primitive :prim_oper p :prim_args args))
     (expandlist
      (l)
      (mapcar (lambda (e) (cold_macroexpand e env)) l)
      )
     )
   (if (consp sexpr)
       (let ( (oper (first sexpr))
	      (args (rest sexpr)) )
	 (if (listp oper)
	     (makeapply 
	      ;; maybe this is too simple, what if the macroexapsnion
	      ;; yields a slector...
	      (cold_macroexpand oper env) (expandlist args))
	   (let ( (obind (cold_find_binding oper env)) )
	     (cond ((cold_macro_binding-p obind)
		    (let ( (mexp (cold_macro_binding-expanser obind)) )
		      (apply mexp (list oper args env))
		      ))
		   ((cold_primitive_binding-p obind)
		    (makeprim (cold_primitive_binding-primitive obind)
			      (expandlist args))
		    )
		   ((cold_field_binding-p obind)
		    (error "field application not yet implemented ~S~%<::cold_macroexpand>" oper))
		   ( (or (cold_selector_binding-p obind)
			 (and (cold_value_binding-p obind)
			      (eq (cold_value_binding-compilrole obind) 
				  'SELECTOR)))
		     (let ( (expargs (expandlist args)) )
		       (if (null expargs) 
			   (error "send requires a reciever argument but got none ~S~%<::cold_macroexpand>" oper))
		     (make-prog_send
		      :send_sel oper
		      :send_recv (first expargs)
		      :send_args (rest expargs)
		      ))
		    )
		   (t (makeapply oper (expandlist args)))
		   ))))
     sexpr
     )))

(defun cold_list_macroexpand (l env)
  (mapcar (lambda (e) (cold_macroexpand e env)) l))


(defmacro defcoldmacro (nam formals &rest body) 
  `(cold_define_macro ',nam (lambda ,formals ,@body)  cold_first_env)
)

(defun write_c_comment (outs coms)
  (write-string "/**!" outs)
  (let ((lencom (length coms)))
    (loop 
     for rk from 0 to (- lencom 2) do
     (let ( (c (char coms rk)) 
	    (nc (char coms (+ rk 1)))
	    )
       (case c 
	     (#\/ (if (eq nc #\*) (write-string "/+" outs) (write-char #\/ outs)))
	     (#\* (if (eq nc #\/) (write-string "*+" outs) (write-char #\* outs)))
	     (otherwise (write-char c outs))
	     ))
     )
    )
  (write-string "!**/" outs)
  (if (find #\Newline coms) (write-char #\Newline outs))
)

(defmacro format_c_comment (str fmtstr &rest args)
  (let ((sy (gentemp "FORMATCCOMM_")))
    `(let ( (,sy (format nil ,fmtstr ,@args)) )
       (write_c_comment ,str ,sy)
       )
    )
)

(defun str2cstr (istr)
  (assert (stringp istr))
  (with-output-to-string
    (s)
    (write-char #\" s)
    (map nil
	 (lambda (c)
	   (case c
		  (#\\ (write-string "\\\\" s))
		  (#\" (write-string "\\\"" s))
		  (#\' (write-string "\\\'" s))
		  (#\Newline (write-string "\\\n" s))
		  (#\Tab (write-string "\\\t" s))
		  (otherwise (if (standard-char-p c) 
				 (write-char c s)
			       (format s "\\x~2,'0x" (char-code c))))
		 )
	   )
	 istr
	 )		
    (write-char #\" s)      
    )
  )

(defun lambda_args_bindings (formals)
  (let ( (argrk 0)
	 (argtype :value) 
	 (arglist formals)
	 (revargbind nil)
	 )
    (loop
     (if (null arglist) 
	 (return (reverse revargbind)))
     (let ( (curarg (car arglist))
	    (restarglist (cdr arglist)) )
       (setq arglist restarglist)
       (cond 
	( (keywordp curarg)
	  (or (cold_valid_type_keyword_p curarg) 
	      (error "invalid formal keyword ~a in formals list ~s ~% <::lambda_args_binding>"
		     curarg formals))
	  (setq argtype curarg)
	  )
	( (symbolp curarg)
	  (let ( (abind (make-cold_formal_binding :bname curarg
						  :rank argrk 
						  :type argtype)) )
	    (push abind revargbind)
	    (setq argrk (1+ argrk))
	    )
	  )
	( t (error "invalid formal (not a symbol or keyword) ~a in formals list ~s ~% <::lambda_args_binding>" curarg formals) )
	)
       ))))


(defvar cold_delayed_task_revlist nil)

(defun cold_delayed_do (msg taskfun)
  (assert (stringp msg))
  (or (functionp taskfun) 
      (error "cold_delayed_do bad taskfun ~s of type ~s ~% <::cold_delayed_do>"
	     taskfun (type-of taskfun)))
  (push (cons msg taskfun) cold_delayed_task_revlist)
)

(defmacro cold_delay (msg &rest body)
  `(cold_delayed_do ,msg (function (lambda () ,@body))))

(defun cold_run_delayed_tasks (&optional msg)
  (and msg (or (stringp msg) (error "bad msg in cold_run_delayed_tasks ~S" msg)))
  (loop 
    (if (null cold_delayed_task_revlist) (return))
    (let ( (taskslist (reverse cold_delayed_task_revlist)) )
      (setq cold_delayed_task_revlist nil)
      (map nil (lambda (taskcons) 
		 ; (warn "delay running task ~S~%" (car taskcons))
		 (apply (cdr taskcons) ())) taskslist)
      ))
  )


(defcoldmacro defprimitive (nam args env)
  (declare (ignore nam))
  (destructuring-bind 
   (primnam formals type &rest body) args
   (or (cold_valid_type_keyword_p type) 
       (error "bad type ~S in defprimitive ~S" type args))
   (assert (every (lambda (x) (or (symbolp x) (numberp x) (stringp x) (not (prog_src-p x)))) body))
   (let ( (prim
	   (make-prog_defprimitive 
	    :def_name primnam
	    :primitive_formals (lambda_args_bindings formals)
	    :primitive_type type 
	    :primitive_expansion body)) )
     (let ( (pbind (make-cold_primitive_binding
		    :bname primnam :primitive prim)) )
       (cold_put_binding pbind env))
     prim
     )
   )
  )

;; a defun function should be expanded in an environment where the
;; defined function is bound, hence we use cold_delay, and the body
;; should be expaned with the formals bound
(defcoldmacro defun (nam args env)
  (declare (ignore nam))
  (destructuring-bind 
   (funam formals &rest body) args
   (let* ( 
	  (argbindseq (lambda_args_bindings formals))
	  (newenv 
	   (let ( (nenv (cold_fresh_env env)) )
	     (map nil 
		  (lambda (abind)  (cold_put_binding abind nenv)) 
		  argbindseq)
	     nenv
	     ))
	  (fun
	   (make-prog_defun 
	    :def_name funam
	    :fun_formals formals
	    :fun_argbindings argbindseq
	    )) 
	  (fbind (make-cold_function_binding :bname funam :function fun
					     :fclodata (make-obj_dataclosure
							:comname funam)
					     )) 
	  )
     (cold_put_binding fbind env)
     (cold_delay
      (format nil "expand defun ~S" funam)
      (setf (prog_defun-fun_body fun)  
	    (mapcar 
	     (lambda (e) (cold_macroexpand e newenv))
	     body)
	    )
      )
     fun
     )))



;;; a class binding
(defcoldmacro defclass (nam args env)
  (declare (ignore nam))
  (destructuring-bind
   (cname &key predef super fields) args
   (assert (symbolp cname) (cname) "invalid class name ~S" cname)
   (let* 
       ( (pdefclass (make-prog_defclass :def_name cname :predef_rank predef)) 
	 (clabind (make-cold_class_binding :bname cname :classdef pdefclass))
	 (superclass 
	  (and super
	       ;;;; we really should consider macro expansion on super
	       (or (symbolp super) (error "bas super ~S in defclass ~S" super args))
	       (let ( (superbind (cold_find_binding super env)) )
		 (or (cold_class_binding-p superbind) 
		     (error "bad superbinding ~S in defclass ~S" superbind args))
		 (cold_class_binding-classdef superbind))))
	 (superallfields
	  (and super
	       (prog_defclass-class_allfields superclass)))
	 (off (if super (length superallfields) 0))
	 )
     (cold_put_binding clabind env)
     (setf (prog_defclass-class_super pdefclass) superclass)
     (let ( (fieldseq 
	     (mapcar 
	      (lambda (f) 
		(or (symbolp f) (error "bad field ~S in defclass ~S" f args))
		(if (cold_find_binding f env) 
		    (error "field ~S already bound in defclass ~S" f args))
		(let* 
		    ( (field (make-prog_field :def_name f :field_class pdefclass :field_offset off)) 
		      (fieldbind (make-cold_field_binding :bname f :fieldef field)) )
		  (incf off)
		  (cold_put_binding fieldbind env)
		  field))
	      fields)) )
       ;; copy-list just to avoid lots of circular ref in debug
       (setf (prog_defclass-class_ownfields pdefclass) 
	     (copy-list fieldseq))
       (setf (prog_defclass-class_allfields pdefclass) 
	     (copy-list (append superallfields fieldseq)))
       pdefclass			;expansion result for defclass
       )
     )))
       


;;; common code to definstance and defselector
(defun instancemakerfun (iname iclassname idata env msg makfun bindfun)
  (let ( (revslots ())
	 (iobjnum ())
	 (ipredef ())
	 (curdata idata) 
	 (bindclass (cold_find_binding iclassname env))
	 )
    (or (symbolp iname) 
	(error "~A: expecting name but got ~S" msg iname))
    (or (cold_class_binding-p bindclass)
	(error "~A: ~A bad classname ~A" msg iname iclassname))
    (let ((iclass (cold_class_binding-classdef bindclass)))
      (assert (prog_defclass-p iclass))
      (loop while (consp curdata) do
	    (or (rest curdata)
		(error "~A: odd arg  ~A  ~S" msg iname idata))
	    (let ((curk (first curdata))
		  (cura (second curdata)) )
	      (setq curdata (cddr curdata))
	      (or (keywordp curk) 
		  (error "~A: expecting slot keyword but got ~S  ~A ~S" msg curk iname idata))
	      (cond ( (eq curk ':obj_num)
		      (setq iobjnum (cold_macroexpand cura env)) )
		    ( (eq curk ':predef)
		      (setq ipredef (cold_macroexpand cura env)) )
		    ( t
		      (let ((fld (find-if 
				  (lambda (f) (equal (string (prog_field-def_name f)) (string curk))) 
				  (prog_defclass-class_allfields iclass)
				  )))
			(or fld (error "~A: unexpected field ~S in ~A ~S" msg curk iname idata))
			(let ((slodef (make-instance_slot 
				       :slot_field fld
				       :slot_value 
				       (cold_macroexpand cura env))))
			  (push slodef revslots))
			)))))
      (let* ( 
	     (nval
	      (funcall makfun
		       iname
		       ipredef
		       iclass
		       iobjnum
		       (reverse revslots)))
	     (nbind (funcall bindfun iname nval))
	     )
	(cold_put_binding nbind env)
	nval
	))))

;;; a class binding
(defcoldmacro definstance (nam args env)
  (declare (ignore nam))
  (destructuring-bind
   (iname iclassname &rest idata) args
   (instancemakerfun iname iclassname idata env "definstance coldmacro" 
		     ;; make value function
		     (lambda (iname ipredef iclass iobjnum islots)
		       (make-prog_definstance :def_name iname
					      :predef_rank ipredef
					      :inst_class iclass
					      :inst_objnum iobjnum
					      :inst_slots islots))
		     ;; make binding function
		     (lambda (iname nval)
		       (make-cold_instance_binding
			:bname iname
			:type ':value
			:instancedef nval
		       ))
		     )))



(defcoldmacro defselector (nam args env)
  (declare (ignore nam))
  (destructuring-bind
   (iname iclassname &rest idata) args
   (instancemakerfun iname iclassname idata env "defselector coldmacro" 
		     ;; make value function
		     (lambda (iname ipredef iclass iobjnum islots)
		       (make-prog_defselector :def_name iname
					      :predef_rank ipredef
					      :inst_class iclass
					      :inst_objnum iobjnum
					      :inst_slots islots))
		     ;; make binding function
		     (lambda (iname nval)
		       (make-cold_selector_binding
			:bname iname
			:type ':value
			:selectordef nval
			))
		     )))


;; the body of a lambda should be macroexpanded with the formals bound
(defvar lambda_counter 0)
(defcoldmacro lambda (nam args env)
  (declare (ignore nam))
  (destructuring-bind 
   (formals &rest body) args
   (let* ( 
	  (argbindseq (lambda_args_bindings formals))
	  (newenv 
	   (let ( (nenv (cold_fresh_env env)) )
	     (map nil 
		  (lambda (abind)  (cold_put_binding abind nenv)) 
		  argbindseq)
	     nenv
	     ))
	  (newlamb
	   (make-prog_lambda :lambda_formals formals
			     :lambda_body 
			     (mapcar 
			      (lambda (e) (cold_macroexpand e newenv))
			      body)
			     :lambda_argbindings argbindseq
			     :lambda_uniq (incf lambda_counter)
			     :lambda_closvars nil))
	  )
     newlamb
)))


;; the forever syntax (FOREVER <label> [<type>] <body...>)
(defcoldmacro forever (nam args env)
  (declare (ignore nam))
  (let ( (foreverlab (pop args))
	 (forevertype :value)
	 (foreverbody nil) 
	 (newenv (cold_fresh_env env))
	 ) 
    (or (symbolp foreverlab) (error "bad forever label in forever ~S" args))
    (if (cold_valid_type_keyword_p (first args))
	(setq forevertype (pop args)))
    (if (eq forevertype ':void) (error "forever type cannot be void in forever ~S" args))
    (setq foreverbody args)
    (let ( (foreverbind (make-cold_forever_binding 
		      :bname foreverlab
		      :type forevertype
		      :uniq (gentemp "_FOREVER_"))) )
      (cold_put_binding foreverbind newenv)
      (make-prog_forever :forever_bind foreverbind 
		      :forever_body (mapcar (lambda (c) (cold_macroexpand c newenv)) foreverbody))
    )))

;; the progn syntax (PROGN <body....>)
(defcoldmacro progn (nam args env)
  (declare (ignore nam))
  (make-prog_progn 
   :progn_body (mapcar  (lambda (c) (cold_macroexpand c env)) args))
)

;; the UNSAFE_GET_FIELD syntax (UNSAFE_GET_FIELD field objexpr)
(defcoldmacro unsafe_get_field (nam args env)
  (declare (ignore nam))
  (let (
	(iargs args)
	(ifldnam (pop args))
	(iobjexpr (pop args)) )
    (if args (error "too many arguments to unsafe_get_field ~S" iargs))
    (or (keywordp ifldnam) 
	(error "first arg should be a keyword fieldname: unsafe_get_field ~S" iargs))
    (make-prog_unsafe_get_field
     :uget_field ifldnam
     :uget_obj  (cold_macroexpand iobjexpr env)
     )
))

;; the UNSAFE_PUT_FIELDS syntax (UNSAFE_PUT_FIELDS objexpr fld1name fld1expr ...)
(defcoldmacro unsafe_put_fields (nam args env)
  (declare (ignore nam))
  (let (
	(iargs args)
	(iobjexpr (pop args)) 
	(irevkeys nil)
	)
    (loop while (and (consp args) (second args)) do
	  (let ( 
		(curfldnam (pop args))
		(curvalexpr (pop args))
		)
	    (or (keywordp curfldnam) 
		(error "expecting keyword fieldname but got ~S in unsafe_put_fields ~S"
		       curfldnam iargs))
	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
	  ))
    (make-prog_unsafe_put_fields
     :uput_obj iobjexpr
     :uput_keys (reverse irevkeys)
     )
))


;; the MAKE_INSTANCE syntax (MAKE_INSTANCE objexpr fld1name fld1expr ...)
(defcoldmacro make_instance (nam args env)
  (declare (ignore nam))
  (let (
	(iargs args)
	(iclass (pop args)) 
	(irevkeys nil)
	)
    (or (symbolp iclass) (error "make_instance need a class symbol ~S" iargs))
    (loop while (and (consp args) (second args)) do
	  (let ( 
		(curfldnam (pop args))
		(curvalexpr (pop args))
		)
	    (or (keywordp curfldnam) 
		(error "expecting keyword fieldname but got ~S in make_instance ~S"
		       curfldnam iargs))
	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
	  ))
    (make-prog_make_instance
     :mki_class (normalize_symbol iclass env)
     :mki_classdef iclass
     :mki_keys (reverse irevkeys)
     )
))

;; the EXIT syntax (EXIT <label> [<expr>])
(defcoldmacro exit (nam args env)
  (declare (ignore nam))
  (let ( (exitlab (pop args)) 
	 (exitexprs args)
	 )
    (or (symbolp exitlab) 
	(error "EXIT need a symbol label: ~S" args))
    (flet ((testnoforenv (env) (null (cold_compenv-for env))))
	  (let ( (exitbind (cold_tested_find_binding exitlab env (function testnoforenv))) )
	    (if (null exitbind) 
		(error "EXIT label ~S is not bound" exitlab))
	    (or (cold_forever_binding-p exitbind)
		(error "label EXIT label ~S not bound to forever ~S" exitlab exitbind))
	    (make-prog_exit 
	     :exit_bind exitbind
	     :exit_body (mapcar (lambda (c) (cold_macroexpand c env)) exitexprs)
	    )))))


;; SETQ syntax
(defcoldmacro setq (nam args env)
  (declare (ignore nam))
  (if (rest (rest args)) (error "SETQ with more than two args ~S" args))
  (destructuring-bind 
   (var expr) args
   (or (symbolp var) (error "bad setq macro args ~S" args))
   (make-prog_setq :setq_var var
		   :setq_expr (cold_macroexpand expr env)
   )))


;;; QUOTE syntax (only for symbols or keywords)
(defcoldmacro quote (nam args env)
  (declare (ignore nam))
  (if (rest args) (error "quote with more than one arg ~S" args))
  (let ((qarg (first args)))
    (or (symbolp qarg) (keywords qarg)
	(error "quote a non-symbol ~S" qarg))
    (make-prog_quotesym :qsym qarg)
))

;; IF syntax
(defcoldmacro if (nam args env)
  (declare (ignore nam))
  (destructuring-bind 
   (scond sthen &optional selse) args
   (make-prog_if 
    :cond_expr (cold_macroexpand scond env)
    :then_expr (cold_macroexpand sthen env)
    :else_expr (if selse (cold_macroexpand selse env)))))

;;; COND pseudo syntax
;;; (COND ( t1 a1_1 a1_2 ) ( t2 a2_1 )) is expansed into 
;;;; (IF t1 (PROGN a1_1 a1_2) (IF t2 a2_1))
(defcoldmacro cond (nam args env)
  (declare (ignore nam))
  (let ( (rescond nil) )
    (loop 
     for clause in (reverse args)
     for rk from 1
     do
     ; (warn "COND clause ~#d == ~S~%" rk clause)
     ;; special case for last (t ...) or (:else ...) clause
     (if (and (<= rk 1) (member (first clause) '(t :else else)))
	 (if (rest (rest clause))
	     (setq rescond (make-prog_progn 
			    :progn_body (mapcar  
					 (lambda (i) (cold_macroexpand i env))
					 (rest clause))))
	   (setq rescond (cold_macroexpand (second clause) env)))
       (let ( (lenclause (length clause)) )
	 (case lenclause 
	       ( 1 (let ( (cndexp (cold_macroexpand (first clause) env)) )
		     (setq rescond (make-prog_if 
				    :cond_expr cndexp 
				    :then_expr cndexp 
				    :else_expr rescond))))
	       ( 0 )
	       ( 2 (let ( (cndexp (cold_macroexpand (first clause) env))
			  (thnexp (cold_macroexpand (second clause) env)) )
		     (setq rescond (make-prog_if 
				    :cond_expr cndexp 
				    :then_expr thnexp 
				    :else_expr rescond))))
	       (otherwise 
		(let ( (cndexp  (cold_macroexpand (first clause) env))
		       (progexprs (mapcar (lambda (i) (cold_macroexpand i env)) (rest clause))) )
		  (setq rescond (make-prog_if
				 :cond_expr cndexp
				 :then_expr (make-prog_progn :progn_body progexprs)
				 :else_expr rescond))))
	       )))
    ; (warn "COND partial rescond #~d == ~S~%" rk rescond)
     )
   ; (warn "COND ~s expands to ~S ;;COND expansion~%" args rescond)
    rescond
    ))

;;; AND pseudo syntax
;;; (AND a1 a2) is expansed into (IF a1 a2)
;;; (AND a1 a2 a3) is expansed into (IF a1 (IF a2 a3))
(defcoldmacro and (nam args env)
  (declare (ignore nam))
  ;; reject (and) without arguments
  (if (null args) (error "(and) without any arguments"))
  (labels ( (expand (a)
		    (if (null (rest a)) 
			(first a)
		      (let ( (a1 (first a)) )
			    (make-prog_if
			     :cond_expr a1
			     :then_expr (expand (rest a))))))
	    ) 
	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) 
  ))

;;; OR pseudo syntax
;;; (OR a1) is expanded as a1
;;; (OR a1 a2) is expanded as (IF a1 a1 a2)
;;; (OR a1 a2 a3) is expanded as (IF a1 a1 (IF a2 a2 a3))
(defcoldmacro or (nam args env)
  (declare (ignore nam))
  ;; reject (or) without arguments
  (if (null args) (error "(or) without any arguments"))
  (labels ( (expand (a)
		    (if (null (rest a)) (first a)
		      (let ( (a1 (first a)) )
			    (make-prog_if
			     :cond_expr a1
			     :then_expr a1
			     :else_expr (expand (rest a)))))) )
	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) )
  )

;; LET syntax
(defcoldmacro let (nam args env)
  (declare (ignore nam))
  (let ( (srcbinds (first args))
	 (srcbody (rest args)) )
    (let ( (revbindseq nil) 
	   (newenv (cold_fresh_env env))
	   )
      (flet ( (bindhandle
	       (sbind)
	       (or (consp sbind) (error "bad src binding ~S in let ~S" sbind args))
	       (let ( (f (first sbind)) 
		      (lensbind (length sbind))
		      )
		 (let ( (newbind		       
			 (cond
			  ( (and (eq lensbind 3) (keywordp f))
			    (let ( (sy (second sbind))
				   (ex (third sbind)) )
			      (or (cold_valid_type_keyword_p f)
				  (error "bad type keyword ~S in let ~S" f args))
			      (or (symbolp sy)
				  (error "non symbol ~S to bind  in let ~S" sy args))
			      (let ( (expa (cold_macroexpand ex newenv)) )
				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
				(make-cold_let_binding :bname sy 
						       :expr expa
						       :type f)
				)))
			  ( (eq lensbind 2) 
			    (let ( (sy (first sbind))
				   (ex (second sbind)) )
			      (or (symbolp sy)
				  (error "non symbol ~S to bind  in let ~S" sy args))
			      (let ( (expa (cold_macroexpand ex newenv)) )
				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
				(make-cold_let_binding :bname sy 
						       :expr expa))))
			  ( t (error "bad binding ~S in let ~S" sbind args) )
			  )))
		   (push newbind revbindseq)
		   (cold_put_binding newbind newenv)
		   ))))
	    (mapc (function bindhandle) srcbinds)
	    (let ( (res
		    (make-prog_let
		     :let_bindings (reverse revbindseq)
		     :let_body (cold_list_macroexpand srcbody newenv)
		     )) )
	      res
	      )))))


;;; MULTICALL syntax
(defcoldmacro multicall (nam args env)
  (declare (ignore nam))
  (if (< (length args) 3) (error "too few arguments to multicall ~S" args))
  (let* (
	 (arglist args)
	 (muformalseq (pop args))
	 (mucall (pop args))
	 (mubody args) 
	 (muformalist (lambda_args_bindings muformalseq))
	 (mufirst (first muformalist))
	 (xcall (cold_macroexpand mucall env))
	 (newenv (cold_fresh_env env))
	 )
    (or (prog_apply-p xcall) (prog_send-p xcall)
	(error "multicall not of ~S application or send ~S" xcall arglist))
    (assert (cold_formal_binding-p mufirst))
    (mapc (lambda (b) (cold_put_binding b newenv)) muformalist)
    (or (eq (cold_typed_binding-type mufirst) ':value)
	(error "first formal of multicall should be a :value in multicall ~S" 
	       arglist))
    (let ( (mc
	    (make-prog_multicall
	     :multicall_formals muformalist
	     :multicall_call xcall
	     :multicall_body  (mapcar (lambda (b) (cold_macroexpand b newenv)) mubody)) 
	    ) )
      mc
      )))


(defcoldmacro return (nam args env)
  (declare (ignore nam))
  (let ( (retpr
	  (make-prog_return :retexprs (mapcar (lambda (b) (cold_macroexpand b env)) args))) )
    ;(break "return macro retptr ~S~%" retpr)
   retpr))


(defgeneric bind_normal_code (cod env)
  (:documentation "normalization of (any) Basilys code, gives binding+normal code")
)


(defgeneric normalize_toplev (def env)
  (:documentation "normalize a toplev definition or code"))

(defmethod bind_normal_code ((cod prog_src) env)
  (declare (ignore env))
  ;; some stuff are already normal, eg defprimitive or quotsym
  (values nil cod)
)


; we frequently may need to make an optional let around something
(defun cold_wrap_let (revbindings cod)
  (assert (listp revbindings))
  (if revbindings
      (progn 
	(assert (cold_let_binding-p (first revbindings)))
	(make-prog_let 
	 :let_bindings (reverse revbindings)
	 :let_body cod))
    cod
    )
  )

; likewise, but needing a sequence
(defun cold_wrap_letseq (revbindings cod)
  (assert (listp revbindings))
  (if revbindings
      (progn 
	(assert (cold_let_binding-p (first revbindings)))
	(make-prog_let 
	       :let_bindings (reverse revbindings)
	       :let_body cod))
    cod)
  )

;; likewise, producing a list
(defun cold_wrap_letlist (revbindings cod)
  (assert (listp revbindings))
  (if revbindings
      (progn 
	(assert (cold_let_binding-p (first revbindings)))
	(list (make-prog_let 
	       :let_bindings (reverse revbindings)
	       :let_body cod)))
    (if (listp cod) cod (list cod))
    ))
  

;;; executable toplev normalisation
(defmethod normalize_toplev ((cod prog_src) env)
  (multiple-value-bind
      (rbind ncod)
      (bind_normal_code cod env)
      (assert (listp rbind))
    (cold_wrap_let rbind ncod)
))



;;- ;; normalization of a symbol occurrence means seeking if the symbol is
;;- ;; closed or not and returning a prog_closedvar when appropriate
(defun normalize_symbol (symb env)
  (or (symbolp symb)
      (error "normalize_symbol bad symb ~s ~%... in env ~s~%" symb env))
  (multiple-value-bind 
      (bnd revlis)
      (cold_enclosed_find_binding symb env)
    (cond ( (null symb)
	    symb			;nil is always nil
	    )
	  ( (cold_class_binding-p bnd)
	    symb			;should make some progconst
	    )
	  ( (cold_instance_binding-p bnd)
	    symb			;should make some progconst of it
	    )
	  ( (cold_selector_binding-p bnd)
	    symb			;should make some progconst of it
	    )
	  ( (cold_function_binding-p bnd)
	    symb			;should make some progconst of it
	    )
	  ( (cold_value_binding-p bnd)
	    symb			;should make some progconst of it
	    )
	  ( (cold_field_binding-p bnd)
	    symb			;should make some progconst of it
	    )
	  ( (null bnd)
	    (error "normalize_symbol ~S unbound in env ~S <:::normalize_symbol unbound ~S in ~S~%"
		   symb env symb (and (prog_defun-p normalized_defun) (prog_defun-def_name normalized_defun))))
	  ( (null revlis) 
	    symb)
	  (t (progn
	       ;; check that a closed symbol is indeed a value
	       (and (cold_typed_binding-p bnd)
		    (not (null (cold_typed_binding-type bnd)))
		    (not (eq (cold_typed_binding-type bnd) ':value))
		    (error "normalize_symbol ~S closed not value ~S" symb bnd))
	;       (break "normalize_symbol symb ~S bnd ~S revlis ~S~%" symb bnd revlis)
	       (let ( (clovs
		       (mapcar 
			(lambda (lr)
			  (assert (prog_lambda-p lr) (lr bnd symb) "normalize_symbol symb=~S bnd=~S expect lr=~S to be a prog_lambda" symb bnd lr)
			  (or 
			   (find-if
			    (lambda (cv)
			      (assert (prog_closedvar-p cv))
			      (eq (prog_closedvar-clv_var cv) symb))
			    (prog_lambda-lambda_closvars lr))
			   (let ( (ncv (make-prog_closedvar 
					:clv_var symb 
					:clv_fun lr
					:clv_bind bnd)) )
			     (push ncv (prog_lambda-lambda_closvars lr))
			     ncv)))
			revlis)) )
		 (first clovs)
		 ))))))



;; we need to normalize a sequence, possibly adding new let_bindings
;; to complex arguments this function returns two results: the
;; normalized sequence and the reversed list of bindings the prefix is
;; for gentemp-ing the variables; the revbindseq argument is the
;; initial value of reversed list of bindings (usually nil)
(defun normalize_code_sequence (seq env prefix  revbindseq)
  (or (listp seq) 
      (error "normalize_code_sequence bad seq ~s" seq))
  (or (cold_compenv-p env) 
      (error "normalize_code_sequence bad env ~s" env))
  (or (stringp prefix)
      (error "normalize_code_sequence bad prefix ~s" prefix))
  (or (listp revbindseq) 
      (error "normalize_code_sequence bad revbindseq ~s" revbindseq))
  (flet (  (handlexpr 
	    (exp) 
	    (cond 
	     ( (prog_src-p exp)
	       (let ( (nsym (gentemp prefix)) )
		 (multiple-value-bind
		  (normrevbind normexp)
		  (bind_normal_code exp env)
		  (assert (listp normrevbind))
		  (if (consp normexp) 
		      (error "bad normexp ~S in normalize_code_sequence seq ~S exp ~S" normexp seq exp))
		  (setq revbindseq (append normrevbind revbindseq))
		  (let ( (newbind  
			  (make-cold_let_binding :bname nsym :expr normexp)) )
		    (if (prog_chunk-p normexp)
			(setf (cold_typed_binding-type newbind)
			      (prog_chunk-chunk_type normexp)))
		    (push newbind
			  revbindseq))
		  nsym
		  ) ))
	     ( (symbolp exp)
	       (normalize_symbol exp env) )
	     ( t exp ))) 
	   )
	(values (mapcar (function handlexpr) seq) revbindseq)))


(defmethod bind_normal_code ((cod null) env)
  (declare (ignore env))
  (values nil nil)
)

(defmethod bind_normal_code ((cod t) env)
  (declare (ignore env))
;  (warn "bind_normal_code t ~S env ~S" cod env)
  (values nil cod)
)

(defmethod bind_normal_code ((cod symbol) env)
  (values nil (normalize_symbol cod env)))


(defmethod bind_normal_code ((cod prog_setq) env)
  (let ( (va (prog_setq-setq_var cod))
	 (ex (prog_setq-setq_expr cod)) )
    (or (symbolp va) (error "prog_setq bad variable ~S~%"))
    (let ((nva (normalize_symbol va env)))
      (multiple-value-bind 
       (nexs pbindseqrev)
       (normalize_code_sequence (list ex) env "_SETQ_" nil)
       (assert (null (rest nexs)))
       (values nil
	       (cold_wrap_let pbindseqrev
			      (make-prog_setq 
			       :setq_var nva
			       :setq_expr (first nexs)
			       )))))))


(defun expand_primitive (srcod poper pargs)
  (let* (
	 (pformals (prog_defprimitive-primitive_formals poper))
	 (pexpansion (prog_defprimitive-primitive_expansion poper))
	 (pnbformals (length pformals))
	 (htb (make-hash-table :size (+ (* 2 pnbformals) 3)))
	 )
    (if (/= pnbformals (length pargs))
	(error "formals/args mismatch in primitive ~S" srcod))
    ;; associate each formal with its actual argument in htb
    (loop
      for rk from 0
      for curform in pformals
      for curarg in pargs
      do
      (let ((curname (cold_any_binding-bname curform)))
	(setf (gethash curname htb) curarg)
	))
    ;; make the expansion
    (let ( (resexp 
	    (mapcar 
	     (lambda (e)
	       (cond 
		((numberp e) e)
		((stringp e) e)
		((symbolp e) 
		 (multiple-value-bind 
		     (symval symhere)
		     (gethash e htb)
		   (cond 
		    ( (stringp symval) (make-prog_cstring :c_str symval)) 
		    ( symhere symval )
		    ( t 
		      (warn "unbound symbol ~S in primitive poper ~S pargs ~S"
			    e poper pargs)
		      e ))
		   ))
		(t (error "bad element ~S in expansion of ~S" e poper))
		))
	     pexpansion))
	   )
      (make-prog_chunk :chunk_args resexp :chunk_type  (prog_defprimitive-primitive_type poper))
      )
    ))

(defmethod bind_normal_code ((cod prog_primitive) env)
  (let* ( (poper (prog_primitive-prim_oper cod))
	  (pargs (prog_primitive-prim_args cod))
	 )
    (multiple-value-bind 
	(normargs pbindseqrev)
	(normalize_code_sequence pargs env "_PARG_" nil)
      (values pbindseqrev
	      (expand_primitive cod poper normargs))
      )))




(defmethod normalize_call ((cod prog_apply) env)
  (let ( (afun (prog_apply-appl_fun cod))
	 (aargs (prog_apply-appl_args cod)) 
	 (abindseqrev nil) )
    ;; normalize the applied function if needed
    (cond  
     ( (prog_src-p afun)
       (multiple-value-bind
	(frbind nfun)
	(bind_normal_code afun env)
	(assert (listp frbind))
	(assert (prog_src-p nfun))
	(let* (
	       (fsym (gentemp "_AFUN_"))
	       (fbind  (make-cold_let_binding
			:bname fsym :expr nfun))
	       )
	  (setq abindseqrev (append frbind abindseqrev))
	  (push fbind abindseqrev)
	  (setq afun fsym))))
     ( (symbolp afun)
       (setq afun (normalize_symbol afun env)) )
     ( t
       (error "bad function to apply in ~s" cod))
     )
    ;; normalize the arguments
    (multiple-value-bind 
     (normargs pbindseqrev)
     (normalize_code_sequence aargs env "_FARG_" abindseqrev)
     (values 
      (make-prog_apply 
       :appl_fun afun
       :appl_args normargs)
      pbindseqrev
      ))))

(defmethod bind_normal_code ((cod prog_apply) env)
  (multiple-value-bind
      (cod bindrev)
      (normalize_call cod env)
    (values bindrev cod)
  ))

;;; normalize a let (gotten from source code)
(defmethod bind_normal_code ((cod prog_let) env)
  (let* ( (lbinds (prog_let-let_bindings cod))
	  (lbody (prog_let-let_body cod)) 
	  (newenv (cold_fresh_env env))
	  (nbinds 
	   (mapcar 
	    (lambda (b) 
	      (let ((nb (copy-cold_let_binding b)))
		(multiple-value-bind
		 (pbindrev pbody)
		 (bind_normal_code (cold_let_binding-expr b) newenv)
		 (assert (listp pbindrev))
		 (setf (cold_let_binding-expr nb)
		       (cold_wrap_let
			pbindrev
			pbody))
		 (cold_put_binding nb newenv)
		 nb)))
	    lbinds))
	  )
    (multiple-value-bind 
     (nbody pbindseqrev)
     (normalize_code_sequence lbody newenv "_LETBODY_" nil)
;;; since the new bindings are gensymed, no risk of conflict with old ones
     (values
      nil
      (cold_wrap_letseq 
       (append pbindseqrev (reverse nbinds))
       nbody)
      )
     )))


;; normalize an if
(defmethod bind_normal_code ((cod prog_if) env)
  (let* ( (icond (prog_if-cond_expr cod))
	  (ithen (prog_if-then_expr cod))
	  (ielse (prog_if-else_expr cod)) )
    (multiple-value-bind 
     (ncond condbindseqrev)
     (normalize_code_sequence (list icond) env "_IFCOND_" nil) 
     ;; if the condition has been gentemp-ed force its binding of type long
     ;; if it had no type
     (let ( (nc1 (first ncond)) )
       (if (symbolp nc1)
	   (let ( (bc1 (find-if (lambda (b) 
				  (and (cold_let_binding-p b)
				       (eq nc1 (cold_any_binding-bname b))))
				condbindseqrev)) )
	     (if (cold_typed_binding-p bc1) 
		 (or (cold_typed_binding-type bc1)
		     (setf  (cold_typed_binding-type bc1) :long))
	       ))))
     (multiple-value-bind
      (thenrevbind normthen)
      (bind_normal_code ithen env)
      (assert (listp thenrevbind))
      (values
       condbindseqrev
       (make-prog_if 
	:cond_expr (first ncond)
	:then_expr (cold_wrap_let thenrevbind normthen)
	:else_expr 
	(if ielse 
	    (multiple-value-bind
	     (elserevbind normelse)
	     (bind_normal_code ielse env)
	     (assert (listp elserevbind))
	     (cold_wrap_let elserevbind normelse))
	  )
	))))))


;; normalize a forever

(defmethod bind_normal_code ((cod prog_forever) env)
  (let* ( (ibind (prog_forever-forever_bind cod))
	  (ibody (prog_forever-forever_body cod)) 
	  (newenv (cold_fresh_env env)) 
	  )
    (cold_put_binding ibind newenv)
    (multiple-value-bind 
	(nbody bindseqrev)
	(normalize_code_sequence ibody newenv "_FOREVERB_" nil)
	(assert (listp bindseqrev))
      (values
       nil
       (make-prog_forever
	:forever_bind ibind
	:forever_body 
	(cold_wrap_letlist
	 bindseqrev nbody
	 ))))))
    


;; normalize an exit
(defmethod bind_normal_code ((cod prog_exit) env)
  (let* ( (ibind (prog_exit-exit_bind cod))
	  (ibody (prog_exit-exit_body cod)) )
    (multiple-value-bind 
     (nbody bindseqrev)
     (normalize_code_sequence ibody env "_EXIT_" nil) 
     (assert (listp bindseqrev))
     (values
      bindseqrev
      (make-prog_exit 
       :exit_bind ibind
       :exit_body nbody
       )))))




;; normalize a progn
(defmethod bind_normal_code ((cod prog_progn) env)
  (let ((ibody (prog_progn-progn_body cod)))
    (values
     nil
     (make-prog_progn
      :progn_body 
      (mapcar 
       (lambda (comp) 
	 (multiple-value-bind 
	  (sbind scod)
	  (bind_normal_code comp env)
	  (assert (listp sbind))
	  (cold_wrap_let
	   sbind scod)
	  ))
       ibody)))))
       

    
;; normalize a multicall
(defmethod bind_normal_code ((cod prog_multicall) env)
  (let ( (iformals (prog_multicall-multicall_formals cod)) ;list of formal bindings
	 (icall (prog_multicall-multicall_call cod))
	 (ibody (prog_multicall-multicall_body cod)) 
	 (newenv (cold_fresh_env env))
	 )
    (mapc (lambda (b) (cold_put_binding b newenv)) iformals)
    (multiple-value-bind 
     (normcall pcallbindseqrev)
     ;;; we should normalize only the sequence of args of the call or send
     ;;; it should stay a call or a send
     (normalize_call icall env)
     (assert (or (prog_send-p normcall) (prog_apply-p normcall)))
     (assert (listp pcallbindseqrev))
     (multiple-value-bind 
      (normbody pbodybindseqrev)
      (normalize_code_sequence ibody newenv "_MULCALLBODY_" nil)
      (assert (listp pbodybindseqrev))
      (values 
       pcallbindseqrev
       (make-prog_multicall
	:multicall_formals iformals
	:multicall_call normcall
	:multicall_body 
	(cold_wrap_letlist
	 pbodybindseqrev normbody
	 )))))))



;; normalize a send
(defmethod normalize_call ((cod prog_send) env)
  (let ( (isel (prog_send-send_sel cod))
	 (irecv (prog_send-send_recv cod))
	 (iargs (prog_send-send_args cod)) )
    (assert (symbolp isel))
    (multiple-value-bind 
     (normrecvargs pbindseqrev)
     (normalize_code_sequence (cons irecv iargs) env "_SEND_" nil)
     (let ( (nrecv (first normrecvargs))
	    (nargs (rest normrecvargs)) 
	    )
       (values
	(make-prog_send
	 :send_sel (normalize_symbol isel env)
	 :send_recv nrecv
	 :send_args nargs)
	pbindseqrev
	)))))

(defmethod bind_normal_code ((cod prog_send) env)
  (multiple-value-bind
   (nsend pbindseqrev)
   (normalize_call cod env)
   (assert (listp pbindseqrev))
   (values pbindseqrev nsend)))

;;; normalize an unsafe_get_field
(defmethod bind_normal_code ((cod prog_unsafe_get_field) env)
  (let ( (ifldname (prog_unsafe_get_field-uget_field cod))
	 (iobjexpr (prog_unsafe_get_field-uget_obj cod)) )
    (let ( (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
      (assert (cold_field_binding-p ifldbind) (ifldbind) 
	      "invalid fldbind ~S for fldname ~S in unsafe_get_field ~S env ~S <:::bad get_field ~S" 
	      ifldbind ifldname cod env ifldname)
      (let ( (fld (cold_field_binding-fieldef ifldbind)) )
	(multiple-value-bind 
	 (nobjbind nobjexpr)
	 (bind_normal_code iobjexpr env)
	 (assert (listp nobjbind))
	 (values 
	  nobjbind
	  (make-prog_unsafe_get_field
	   :uget_field fld
	   :uget_obj nobjexpr)
	  ))))))


;;; normalize an unsafe_put_fields
(defmethod bind_normal_code ((cod prog_unsafe_put_fields) env)
  (let ( (iobjexpr (prog_unsafe_put_fields-uput_obj cod))
	 (ikeys (prog_unsafe_put_fields-uput_keys cod)) 
	 (nrevkeys nil)
	 )
    ;; check key symbols and make the list of fields
    (let (
	(fieldlist 
	 (mapcar (lambda (kpair) 
	    (let* ( (ifldname (car kpair))
		    (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
	      (assert (cold_field_binding-p ifldbind) (ifldbind) 
		      "invalid fldbind ~S in unsafe_put_fields ~S fldname ~S env ~S" ifldbind cod ifldname env)
	       (cold_field_binding-fieldef ifldbind)
	      ))
	  ikeys))
	)
    ;; normalize the object expression
    (multiple-value-bind
     (nobjbinds nobjexpr)
     (bind_normal_code iobjexpr env)
     ;;; normalize the field expressions
     (multiple-value-bind
      (nkeyexprs nkeybinds)
      (normalize_code_sequence
       (mapcar #'cdr ikeys)
       env "_UPUTF_"  nobjbinds)
      ;;; make the normalized key pairs
      (mapc 
       (lambda (fld nexpk)
	 (push (cons fld nexpk) nrevkeys)
	 ) fieldlist nkeyexprs)
      (values
       nkeybinds
       (make-prog_unsafe_put_fields
	:uput_obj nobjexpr
	:uput_keys (reverse nrevkeys))
       ))))))




;;; normalize an make_instance
(defmethod bind_normal_code ((cod prog_make_instance) env)
  (let ( (iclass (prog_make_instance-mki_class cod))
	 (ikeys (prog_make_instance-mki_keys cod)) 
	 (nrevkeys nil)
	 )
    ;; check class & key symbols and make the list of fields
    (let* (
	   (classbind (cold_find_binding iclass env))
	   (classdef (if (cold_class_binding-p classbind) 
			 (cold_class_binding-classdef classbind)
		       (error "make_instance ~S not a class bind ~S env ~S"
			      iclass classbind env)))
	   (fieldlist 
	    (mapcar (lambda (kpair) 
		      (let* ( (ifldname (car kpair))
			      (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
			(assert (cold_field_binding-p ifldbind) (ifldbind) 
				"invalid fldbind ~S in make_instance ~S for fldname ~S env ~S<:: bad make_instance fieldname ~S~%"
				ifldbind cod ifldname env ifldname)
			(let* ( (fld (cold_field_binding-fieldef ifldbind)) 
				(fldoff (prog_field-field_offset fld))
				)
			  (assert (eq (nth fldoff (prog_defclass-class_allfields classdef)) fld)
				  (fld)
				  "bad field ~S in make_instance ~S" fld cod)
			  fld
			  )
			))
		    ikeys))
	   )
;;; normalize the field expressions
      (multiple-value-bind
       (nkeyexprs nkeybinds)
       (normalize_code_sequence
	(mapcar #'cdr ikeys)
	env "_UMKI_"  nil)
;;; make the normalized key pairs
       (mapc 
	(lambda (fld nexpk)
	  (push (cons fld nexpk) nrevkeys)
	  ) fieldlist nkeyexprs)
       (values
	nkeybinds
	(make-prog_make_instance
	 :mki_class (normalize_symbol iclass env)
	 :mki_classdef classdef
	 :mki_keys (reverse nrevkeys))
	)))))



;; normalize the body of a lambda or a function
;; hence put an implicit return on last element
(defun normalize_body (body env)
  (assert (cold_compenv-p env))
  (or (listp body) (error "bad body ~S for normalize_body ~%" body))
  (multiple-value-bind
   (nseq nbind)
   (normalize_code_sequence body env "_BODY_" nil)
   (assert (listp nbind))
   (if (listp nseq)
       (let ( (bl (butlast nseq))
	      (l  (last nseq)) )
	 (if (prog_return-p (first l))
	     (cold_wrap_letseq nbind nseq)
	   (cold_wrap_letlist
	    nbind 
	    (append bl (list (make-prog_return :retexprs l)))
	    )
	   )))))



;;;;;;; normalize a lambda
(defmethod bind_normal_code ((cod prog_lambda) env)
  (let* ( (formals (prog_lambda-lambda_formals cod))
	  (body (prog_lambda-lambda_body cod))
	  (argbs (prog_lambda-lambda_argbindings cod))
	  (newenv (cold_fresh_env env))
	  (ncod (copy-prog_lambda cod))
	  )
    (setf (cold_compenv-for newenv) ncod)
    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
    (let*( (nbody (normalize_body body newenv))
	   (nfnam (gentemp "_LAMBDAFUN_"))
	   (nclosv  (prog_lambda-lambda_closvars ncod))
	   (nfun (make-prog_defun
		  :def_name nfnam
		  :fun_formals formals
		  :fun_argbindings argbs
		  :fun_body nbody
		  :fun_lambda cod
		  :fun_closvars nclosv))
	   ;; call normalize_symbol on each closed variable in the lambda
	   ;; with the side-effect of propagating, if necessary, the closed
	   ;; variables into the current function
	   (closvseq (mapcar (lambda (cv) 
			       (normalize_symbol (prog_closedvar-clv_var cv) env)) 
			     nclosv))
	   )
      (push nfun (compilation-functions this_compilation))
      (setf (prog_lambda-lambda_body ncod) nbody)
      (cold_delay
       "addobjcode lambda"
       (let ( (cofun (compile_obj nfun newenv)) ) 
	 (add_objcode cofun)
	 )
       )
      (let( (mkclos 
	     (make-prog_makeclosure
	      :mkclos_fun nfun
	      :mkclos_closvars closvseq)) )
	(values nil mkclos)
	))))



(defmethod bind_normal_code ((cod prog_return) env)
  (let ( (retargs (prog_return-retexprs cod)) )
    ;; normalize the arguments
    (multiple-value-bind 
     (normargs pbindseqrev)
     (normalize_code_sequence retargs env "_RETARG_" ())
     (values pbindseqrev
	     (make-prog_return
	      :retexprs normargs)
	     ))))

	  


(defvar normalized_defun nil)
  
(defmethod normalize_toplev ((cod prog_defun) env)
  (let* ( (ncod (copy-prog_defun cod)) 
	  (fbody (prog_defun-fun_body cod))
	  (argbs (prog_defun-fun_argbindings cod))
	  (newenv (cold_fresh_env env))
	  )
    (setq normalized_defun cod)
    (setf (cold_compenv-for newenv) ncod)
    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
    (let( (nbody (normalize_body fbody newenv)) )
      (setf (prog_defun-fun_body ncod) nbody))
    (setq normalized_defun ())
    ncod
    ))
  


(defmethod normalize_toplev ((cod prog_definstance) env)
  (let* ( (ncod (copy-prog_definstance cod)) 
	  (slots (prog_definstance-inst_slots cod))
	  (nslots 
	   (mapcar 
	    (lambda (s) 
	      (assert (instance_slot-p s))
	      (make-instance_slot 
	       :slot_field (instance_slot-slot_field s)
	       :slot_value 
	       (multiple-value-bind
		   (sbind sexpr)
		   (bind_normal_code 
		    (instance_slot-slot_value s)
		    env)
		 (cold_wrap_let sbind sexpr))))
	    slots)) )
    (setf (prog_definstance-inst_slots ncod) nslots)
    ncod)
  )

(defmethod normalize_toplev ((cod prog_defselector) env)
  (let* ( (ncod (copy-prog_defselector cod)) 
	  (slots (prog_defselector-inst_slots cod))
	  (nslots 
	   (mapcar 
	    (lambda (s) 
	      (assert (instance_slot-p s))
	      (make-instance_slot 
	       :slot_field (instance_slot-slot_field s)
	       :slot_value 
	       (multiple-value-bind
		   (sbind sexpr)
		   (bind_normal_code 
		    (instance_slot-slot_value s)
		    env)
		 (cold_wrap_let sbind sexpr))))
	    slots)) )
    (setf (prog_defselector-inst_slots ncod) nslots)
    ncod)
  )

;;;;;;;;;;;; compile to object
(defstruct compilation
  functions				;list of prog- functions
  currout				;current routine
  initrout				;initialization routine
  revobjcode				;generated object code reversed list
  cdata					;constructed data
  symboldict				;dictonnary of gererated symbols
)



;; sometimes we need to take the length of a stuff and round it to 1 if it is empty
(defun my_length_gt_1 (s) 
  (let  ( (l (length s)) )
    (if (> l 0) l 1)))

(defstruct obj_instr
)

(defgeneric output_ccode (obj str)
  (:documentation "output C code from Basilys code")
)

(defgeneric output_cdecl (obj str)
  (:documentation "output C declaration from Basilys code")
)

(defmethod output_ccode ((obj t) str)
  (error "invalid arg (type ~A) to output_ccode ~S" (type-of obj)  obj)
)

(defmethod output_ccode ((obj symbol) str)
  (format str "/*@Symb*/((void*)(BASILYSG(~S)))" obj))

(defmethod output_ccode ((obj null) str)
  (format str "/*@Nil*/NULL"))

(defmethod output_ccode ((obj string) str)
  (format str "/*@String*/~S" obj))

(defmethod output_ccode ((obj integer) str)
  (format str "/*@Integer*/~S" obj))

(defmethod output_cdecl ((obj t) str)
  (error "unexpected output_cdecl (type ~A) ~S~%" (type-of obj) obj)
  (format_c_comment str "**@declobj t![~A]~%~S~%**" (type-of obj) obj))

(defstruct (obj_get_arguments (:include obj_instr))
  instrs
)

(defstruct (obj_verbatim)
  vstr)

(defstruct (obj_verbatiminstr (:include obj_instr))
  vstr)

(defmethod  print-object ((ob obj_verbatim) st)
  (let ((*print-circle* nil))
  (format st "{ObVerb ~S}" (obj_verbatim-vstr ob))))

(defmethod output_ccode ((obj obj_verbatim) str)
  (write-string (obj_verbatim-vstr obj) str)
)

(defmethod  print-object ((ob obj_verbatiminstr) st)
  (let ((*print-circle* nil))
  (format st "{ObVerbIns ~S}" (obj_verbatiminstr-vstr ob))))

(defmethod output_ccode ((obj obj_verbatiminstr) str)
  (write-string (obj_verbatiminstr-vstr obj) str)
)

(defstruct (obj_cstring)
  obcstr)

(defmethod output_ccode ((obj obj_cstring) str)
  (let ( (cstri (obj_cstring-obcstr obj)) 
	 )
    (format_c_comment str "obj_cstring ~S" cstri)
    (write-string " \"" str)
    (map nil 
	 (lambda (c) 
	   (case c
		 (#\Newline (write-string "\\n" str))
		 (#\Tab  (write-string "\\t" str))
		 (#\\ (write-string "\\\\" str))
		 (#\' (write-string "\\'" str))
		 (#\" (write-string "\\\"" str))
		 (otherwise (if (standard-char-p c)
				(write-char c str)
			      (format str "\\x~2,'0x" (char-code c))))
		 )
	   )
	 cstri)
    (write-string "\" " str)
    ))


(defmethod output_ccode ((obj prog_src) str)
  (format_c_comment str "~%*** progsrc ~S ***~%~%" obj))

(defgeneric query_ctype (obj)
  (:documentation "query type of C code")
)

(defmethod query_ctype ((obj t))
nil)

(defgeneric put_destination (obj dest)
  (:documentation "set the destination of C code from Basilys code & return nil or a new objectocde")
)

(defgeneric get_destination (obj)
  (:documentation "retrieve the destination of C code from Basilys code")
)

(defmethod put_destination ((obj t) dest)
;  (warn "default put_destination obj ~S dest ~S" obj dest)
  (if (prog_src-p obj) (error "put_destination prog_src obj ~S" obj))
  (build_obj_compute
   dest
   (list obj)
   (query_ctype obj))
)

(defmethod put_destination ((obj integer) dest)
  (build_obj_compute
   dest
   (list obj)
   :long)
)

(defmethod put_destination ((obj string) dest)
  (error "put_destination stringobj ~S dest ~S" obj dest)
  (build_obj_compute
   dest
  (list obj)
  nil)
)

(defmethod get_destination ((obj t))
  nil					;do nothing by default
)

(defmethod output_ccode ((obj cons) str)
  (format str "/*@list ~d*/ " (length obj))
  (mapc (lambda (o) 
	  (format str "~%")
	  (output_ccode o str)) 
	obj)
  (format str "/*@endlist ~d*/ " (length obj)))

(defmethod output_ccode ((obj obj_get_arguments) str)
  (let (( instrs (obj_get_arguments-instrs obj)))
    (format str "/*obj_get_arguments ~d*/~%" (length instrs))
    (mapc (lambda (i) (format str "~%") (output_ccode i str)) instrs)
    (format str " goto lab_endargs;~%")
    (format str "lab_endargs: ;~%")
    )
)


(defstruct  (obj_clearptr (:include obj_instr))
  clrptrvar
)

(defmethod output_ccode ((obj obj_clearptr) str)
  (format str "/*clearptr*/ ")
  (output_ccode (obj_clearptr-clrptrvar obj) str)
  (format str " = NULL;~%")
)

(defstruct  (obj_clearlong (:include obj_instr))
  clrlongvar
)

(defmethod output_ccode ((obj obj_clearlong) str)
  (format str "/*clearlong*/ ")
  (output_ccode (obj_clearlong-clrlongvar obj) str)
  (format str " = 0L;~%")
)


(defstruct (obj_data)
  discr					;the discriminant
  comname				;comment name
  )


;; add a data to the constdata pool of the compilation; so append the
;; data to cdata, create a cdata binding for it an a pointerobjvar for
;; it in the initial routine
(defun add_cdata (da &optional why)
  (assert (listp  (compilation-cdata this_compilation)))
  (and (listp da) (error "bad list cdata ~S" da))
  (assert (obj_data-p da) (da) "bad cdata ~S" da)
  (assert (not (member da (compilation-cdata this_compilation))))
  (push da (compilation-cdata this_compilation))
  (assert (listp  (compilation-cdata this_compilation)))
  (let* ( (nbdata (length  (compilation-cdata this_compilation)))
	  (initrout (compilation-initrout this_compilation))
	  (dbind  (make-cold_cdata_binding 
			   :bname (gentemp "CDATA_")
			   :type :value
			   :cdata da)) 
	  (ovar (newobjptrvar initrout dbind 
			   (if why 
			       (concatenate 'string "addCdata " (string why))
			     "added cdata"))) )  
    (setf (gethash da (obj_initroutine-inirou_datarankdict initrout)) nbdata)
    (routine_link_data2ptr initrout da ovar)
    )
  ;; (format *error-output* "add_cdata da ~S~%" da)
  da
  )

(defun add_objcode (ob)
  (assert (listp  (compilation-revobjcode this_compilation)))
  (assert (obj_routine-p ob) (ob) "adding bad objcode ~S" ob)
  (push ob (compilation-revobjcode this_compilation))
  (assert (listp  (compilation-revobjcode this_compilation)))
  nil
)

;(defun put_progdata (pro &optional datagetfun)
;  (assert (prog_src-p pro) (pro) "put bad progdata ~S" pro)
;  (or  (gethash pro (compilation-progdict this_compilation))
;       (if datagetfun
;	   (let ((data (apply datagetfun (list pro))))
;	     (assert (obj_data-p data) (data) "bad computed data ~S for progdata ~S" data pro)
;	     (setf (gethash pro  (compilation-progdict this_compilation))
;		   data)
;	     (or (currout_data2ptr data) (add_cdata data))
;	     data
;	     ))))
;
;(defun progdata (pro)
; (gethash pro (compilation-progdict this_compilation)))
;
;(defun checked_progdata (pro)
;  (or  (gethash pro (compilation-progdict this_compilation))
;       (error "prog without data ~S" pro)))
;

(defmethod output_ccode ((obj obj_data) str)
  (format str " /*-*ccode objdata ~S */ " (obj_data-comname obj))
  (let ( (optr (currout_data2ptr obj)) )
    (assert optr (obj optr) "output_ccode data ~S without ptr" obj)
    (output_ccode optr str))
;  (finish-output str)
)

(defgeneric output_cassign (obda str)
  (:documentation "output the code to assign the data"))

(defgeneric output_cinit (obda str)
  (:documentation "output the code to initialize the data"))

(defgeneric output_cfill (obda str)
  (:documentation "output the code to fill the initialized data"))

(defgeneric output_cverify (obda str)
  (:documentation "output the code to verify the initialized data"))

(defgeneric output_cref (obda str)
  (:documentation "output the code to reference the data"))

(defmethod output_cassign ((obda obj_data) str)
  (let ( (cmsg (with-output-to-string 
		(s) 
		(format s "cassign/data cleared ~S #~d [~S]"
			(obj_data-comname obda) (initrout_rank obda) (type-of obda)))) )
    (format str "basilys_assertmsg(~a, NULL=="
	    (str2cstr cmsg)))
  (output_ccode (currout_data2ptr obda) str)
  (format str ");~%")
  (format str "/*cassign data ~S #~d [~S] */~%"
	  (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (output_ccode (currout_data2ptr obda) str)
  (format str " = (void*) (&cdat->inidat_~d_);~%" (initrout_rank obda))
  (format str "#if COLD_BASILYS_DEBUG~%")
  (format str " debugeprintf(\" %s %p @%d\", ")
  (write-string 
   (str2cstr 
    (with-output-to-string (s)
			   (format s "cassign data ~S #~d [~S]"
				     (obj_data-comname obda) 
				     (initrout_rank obda) 
				     (type-of obda))))
   str)
  (format str ", (void*) (&cdat->inidat_~d_), " (initrout_rank obda))
  (format str " (int)offsetof(cdata_t, inidat_~d_));~%"  (initrout_rank obda))
  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
  )


(defmethod output_cinit ((obda obj_data) str)	
  (finish-output str)
  (error "cannot output_cinit objdata ~S~%" obda)
)


(defmethod output_cfill ((obda obj_data) str)	
  (finish-output str)
  (error "cannot output_cfill objdata ~S~%" obda)
)



(defmethod output_cref ((obda obj_data) str)		
  (format str " /*cref ~S [~S] #~d*/" (obj_data-comname obda) (type-of obda) (initrout_rank obda))
  (format str " ((void*) (&cdat->inidat_~d_)) " (initrout_rank obda))
;  (finish-output str)
)

(defstruct (obj_dataclosure (:include obj_data))
  rout					;the routine
  clodata				;closed data
  )

(defmethod output_ccode ((obj obj_dataclosure) str)
  (format str " /*-*ccode objdataclosure ~S:*/ " (obj_data-comname obj))
  (output_ccode (currout_data2ptr obj) str)
;  (finish-output str)
)

(defmethod output_cverify ((obda obj_dataclosure) str)	
;  (finish-output str)
  (format str "/*cverify dataclosure ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (format str "basilys_assertmsg(\"cverify dataclosure ~S #~d\", basilys_magic_discr((" 
	  (obj_data-comname obda) (initrout_rank obda))
  (output_ccode (currout_data2ptr obda) str)
  (format str ")) == OBMAG_CLOSURE);~%")
)

(defmethod  print-object ((ob obj_dataclosure) st)
  (let ( (obcna (obj_data-comname ob))
	 (dis (obj_data-discr ob))
	 (rou (obj_dataclosure-rout ob))
	 (cld (obj_dataclosure-clodata ob)) )
    (if (obj_routine-p rou)
	(format st "#{ObjDataClosure ~S discr=~S rout/~a clodata=~S}"
		obcna dis (prog_defun-def_name (obj_routine-pfun rou)) cld)
      (call-next-method ob st)
	  ))
)

(defstruct (obj_dataroutine (:include obj_data))
  rout					;the routine
  roudata				;routine data (reversed order), ie quoted constants
)



(defmethod print-object ((ob obj_dataroutine) st)
  (let ( (obcna (obj_data-comname ob))
	 (pvar (currout_data2ptr ob))
	 (dis (obj_data-discr ob))
	 (rou (obj_dataroutine-rout ob))
	 (rd (obj_dataroutine-roudata ob)) )
    (if (obj_routine-p rou)
	(format st "#{ObjDataRoutine ~S ptrva=~S discr=~S rout/~a roudata*~d=~S}"
		obcna pvar dis (prog_defun-def_name (obj_routine-pfun rou)) (length rd) rd)
      (call-next-method ob st)
	  ))
)


(defmethod output_ccode ((obj obj_dataroutine) str)
  (format str " /*-*ccode objdataroutine ~S:*/ " (obj_data-comname obj))
  (output_ccode (currout_data2ptr obj) str)
;  (finish-output str)
)

(defmethod output_cverify ((obda obj_dataroutine) str)	
;  (finish-output str)
  (format str "/*cverify dataroutine ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (format str "basilys_assertmsg(\"cverify dataroutine ~S #~d\", basilys_magic_discr(("
	  (obj_data-comname obda) (initrout_rank obda))
  (output_ccode (currout_data2ptr obda) str)
  (format str ")) == OBMAG_ROUTINE);~%")
)

(defstruct (obj_datainstance (:include obj_data))
  predef				;name of predefined rank or nil
  objnum				;number (maybe magic) in instance
  slots					;list of slot values
)

(defmethod  print-object ((ob obj_datainstance) st)
  (let ( (obcna (obj_data-comname ob))
	 (obdiscr (obj_data-discr ob))
	 (obpredef (obj_datainstance-predef ob))
	 (obnum (obj_datainstance-objnum ob))
	 (obslots (obj_datainstance-slots ob)) )
    (if (obj_datainstance-p obdiscr)
	(progn
	  (format st "#{ObjDataInst ~S Discr:~S" obcna (obj_data-comname obdiscr))
	  (if obpredef (format st " Predef:~S" obpredef))
	  (if obnum (format st " ObjNum:~S" obnum))
	  (if obslots (format st " Slots:~S" obslots))
	  )
      (call-next-method ob st)
      )))

(defmethod output_ccode ((obj obj_datainstance) str)
  (format str " /*-*ccode objdatainstance ~S :*/ " (obj_data-comname obj))
  (let ( (op (currout_data2ptr obj)) )
    (or op (error "output_ccode obj datainst ~S without data2ptr" obj))
    (output_ccode op str)
;    (finish-output str)
    ))

(defmethod output_cverify ((obda obj_datainstance) str)	
;  (finish-output str)
  (format str "/*cverify datainstance ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (format str "basilys_assertmsg(\"cverify  datainstance ~S #~d\", basilys_magic_discr(("
	  (obj_data-comname obda) (initrout_rank obda))
  (output_ccode (currout_data2ptr obda) str)
  (format str ")) == OBMAG_OBJECT);~%")
)

(defstruct (obj_datamultiple (:include obj_data))
  values
)

(defstruct (obj_datastring (:include obj_data))
  string
)

(defstruct (obj_dataqsymbol (:include obj_data))
  qsymb)

(defstruct (obj_dataqkeyword (:include obj_data))
  qkeyword)
	
;;;;;; quoted symbol data
(defmethod output_cdecl ((obj obj_dataqsymbol) str)
  (format str "/*cdecl dataqsymbol ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
  (format str "char* iniqsymb_~d;~%"  (initrout_rank obj))
  )
	   
(defmethod output_cassign ((obj obj_dataqsymbol) str)
  (format str "/*cassign dataqsymbol ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
  (output_ccode (currout_data2ptr obj) str)
  (format str " = basilysgc_new_symbol(~a);~%" (str2cstr (string (obj_dataqsymbol-qsymb obj))))
  (format str "#if COLD_BASILYS_DEBUG~%")
  (format str " debugeprintf(\" quoted symbol ~S @%p\","  (obj_dataqsymbol-qsymb obj))
  (output_ccode (currout_data2ptr obj) str)
  (format str ");~%")
  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
)	   

(defmethod output_cinit ((obj obj_dataqsymbol) str)
  (format str "/*cinit dataqsymbol ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
  (format str " cdat->iniqsymb_~d = ~a;~%"  (initrout_rank obj) 
	  (str2cstr  (string (obj_dataqsymbol-qsymb obj))))
)

(defmethod output_cfill ((obj obj_dataqsymbol) str)
  (format str "/*no cfill dataqsymbol ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
)

(defmethod output_cref ((obj obj_dataqsymbol) str)
  (format str "/*no cref dataqsymbol ~S #~d [~S] - '~S*/~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
)

(defmethod output_cverify ((obj obj_dataqsymbol) str)
  (format str "/*no cverify dataqsymbol ~S #~d [~S] - '~S*/~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
)



;;;;;;;; quoted keyword data		     
(defmethod output_cdecl ((obj obj_dataqkeyword) str)
  (format str "/*cdecl dataqkeyword ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
  (format str "char* iniqkey_~d;~%"  (initrout_rank obj))
  )
	   
(defmethod output_cassign ((obj obj_dataqkeyword) str)
  (format str "/*cassign dataqkeyword ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
  (output_ccode (currout_data2ptr obj) str)
  (format str " = basilysgc_new_keyword(~a);~%" (str2cstr (string (obj_dataqkeyword-qkeyword obj))))
  (format str "#if COLD_BASILYS_DEBUG~%")
  (format str " debugeprintf(\" quoted keyword ~S @%p\"," (obj_dataqkeyword-qkeyword obj))
  (output_ccode (currout_data2ptr obj) str)
  (format str ");~%")
  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
)	   

(defmethod output_cinit ((obj obj_dataqkeyword) str)
  (format str "/*cinit dataqkeyword ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
  (format str " cdat->iniqkey_~d = ~a;~%"  (initrout_rank obj) 
	  (str2cstr  (string (obj_dataqkeyword-qkeyword obj))))
)

(defmethod output_cfill ((obj obj_dataqkeyword) str)
  (format str "/*no cfill dataqkeyword ~S #~d [~S] - '~S */~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
)

(defmethod output_cref ((obj obj_dataqkeyword) str)
  (format str "/*no cref dataqkeyword ~S #~d [~S] - '~S*/~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
)

(defmethod output_cverify ((obj obj_dataqkeyword) str)
  (format str "/*no cverify dataqkeyword ~S #~d [~S] - '~S*/~%"
	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
)

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


(defmethod output_cdecl ((obj obj_dataclosure) str)
  (format str "/*- decl dataclosure ~S -*/~%" (obj_data-comname obj))
  (format str " struct BASILYS_CLOSURE_STRUCT(~d) inidat_~d_;~%" 
	  (my_length_gt_1 (obj_dataclosure-clodata obj)) (initrout_rank obj))
)


(defmethod output_cinit ((obj obj_dataclosure) str)
    (format str "/*- init dataclosure ~S-*/~%" (obj_data-comname obj))
    (let ( (irk (initrout_rank obj)) )
      (assert (integerp irk))
      (format str " cdat->inidat_~d_.discr = " irk)
      (output_ccode (obj_data-discr obj) str) 
      (format str ";~%")
      (format str " cdat->inidat_~d_.rout = " irk)
      (output_cref (obj_routine-datarout (obj_dataclosure-rout obj)) str)
      (format str ";~%")
      (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataclosure-clodata obj)))
))


(defmethod output_cfill ((obj obj_dataclosure) str)
  (let ( (ov  (currout_data2ptr obj))
	 )
    (format str "/*- cfill dataclosure ~S -*/~%" (obj_data-comname obj))
    (format str " basilys_assertmsg(\"cfill dataclosure ~S\", basilys_magic_discr((" (obj_data-comname obj))
    (output_ccode ov str)
    (format str ")) == OBMAG_CLOSURE);~%")
    (let ( (nbd  (length  (obj_dataclosure-clodata obj))) )
      (if (> nbd 0) 
	  (progn
	    (format str " basilys_assertmsg(\"cfill len dataclosure ~S\", ((basilysclosure_ptr_t)("
		    (obj_data-comname obj))
	    (output_ccode ov str)
	    (format str "))->nbval >= ~d);~%" nbd))))
    (loop
     for crk from 0
     for cda in (obj_dataclosure-clodata obj)
     do
     (format str " ((basilysclosure_ptr_t)(")
     (output_ccode ov str)
     (format str "))->tabval[~d] = " crk)
     (output_ccode cda str)
     (format str ";~%")
     )
     (format str " basilysgc_touch(")
     (output_ccode ov str)
     (format str ");~%")     
  ))

(defmethod output_cdecl ((obj obj_dataroutine) str)
    (let ( (irk (initrout_rank obj)) )
  (format str "/*- decl dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
      (format str " struct BASILYS_ROUTINE_STRUCT(~d) inidat_~d_;~%" 
	      (my_length_gt_1 (obj_dataroutine-roudata obj)) irk)
  ))

(defmethod output_cinit ((obj obj_dataroutine) str)
  (let ( (irk (initrout_rank obj)) )
    (format str "/*- init dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
    (format str " cdat->inidat_~d_.discr = " irk)
    (output_ccode (obj_data-discr obj) str) 
    (format str ";~%")
    (format str " strncpy(cdat->inidat_~d_.routdescr, \"~S\", BASILYS_ROUTDESCR_LEN-1);~%" 
 	    irk (prog_defun-def_name (obj_routine-pfun (obj_dataroutine-rout obj))))
    (format str " *(basilysroutfun_t **)(cdat->inidat_~d_.routaddr) = ~a;~%"
	    irk (routinecname (obj_dataroutine-rout obj)))
    (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataroutine-roudata obj)))
    ))
  

(defmethod output_cfill ((obj obj_dataroutine) str)
  (let (
	(op (currout_data2ptr obj))
	(irk (initrout_rank obj))
	)
    (format str "/*-cfill dataroutine ~S #~d -*/~%" (obj_data-comname obj) irk)
    (format str " basilys_assertmsg(\"cfill dataroutine ~S #~d\", basilys_magic_discr((" (obj_data-comname obj) irk)
    (output_ccode op str)
    (format str ")) == OBMAG_ROUTINE);~%")
    (let ( (nbd  (length (obj_dataroutine-roudata obj))) )
      (if (> nbd 0) 
	  (progn 
	    (format str " gcc_assert(((basilysroutine_ptr_t)(")
	    (output_ccode op str)
	    (format str "))->nbval >= ~d);~%" nbd))))
    (loop
     for crk from 0
     for cda in (reverse (obj_dataroutine-roudata obj))
     do
     (format str "((basilysroutine_ptr_t)(")
     (output_ccode op str)
     (format str "))->tabval[~d] = " crk)
     (output_ccode cda str)
     (format str ";~%")
     )
    (format str " basilysgc_touch(")
    (output_ccode op str)
    (format str ");~%")
;    (finish-output str)
    ))

(defmethod output_cdecl ((obj obj_datainstance) str)
  (let ( (irk (initrout_rank obj)) )
  (format str "/*- decl datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
  (format str " struct BASILYS_OBJECT_STRUCT(~d) inidat_~d_;~%" 
	  (my_length_gt_1 (obj_datainstance-slots obj)) irk)
;  (finish-output str)
))


(defmethod output_cinit ((obj obj_datainstance) str)
  (let ( (irk (initrout_rank obj)) )
    (format str "/*- init datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
   (format str " cdat->inidat_~d_.obj_class = " irk)
   (output_ccode (obj_data-discr obj) str) 
   (format str ";~%")
   (format str " cdat->inidat_~d_.obj_len = ~d;~%" irk (length (obj_datainstance-slots obj)));
   (format str " cdat->inidat_~d_.obj_vartab =  cdat->inidat_~d_.obj__tabfields; ~%" irk irk)
   ;; 134217728 is 2**27 so the hash is >0
   (format str " cdat->inidat_~d_.obj_hash = ~d;~%" irk (+ 1 (random 134217728)))
   (let ((onu (obj_datainstance-objnum obj)))
     (if onu 
	  (format str " cdat->inidat_~d_.obj_num = ~S;~%" irk onu)
	)))
    )

(defmethod output_cassign ((obda obj_datainstance) str)
  (let ( (irk (initrout_rank obda)) )
    (format str "/*cassign datainstance ~S #~d*/" (obj_data-comname obda) irk)
    (format str "basilys_assertmsg(\"cassign datainstance ~S #~d cleared\", NULL=="
	    (obj_data-comname obda) irk)
    (output_ccode (currout_data2ptr obda) str)
    (format str ");~%")
    (let ((prd (obj_datainstance-predef obda)))
      (cond (( null prd) )
	    ((symbolp prd) (format str "/*predef sym*/BASILYSG(~S) = " prd))
	    ((integerp prd) (format str "/*predef num*/basilys_globarr[~d] = " prd))
	    (t  (error "bad predef ~S in obj_datainstance ~S" prd obda)))
      )
    (output_ccode (currout_data2ptr obda) str)
    (format str " = (void*) (&cdat->inidat_~d_);~%" irk)
;    (finish-output str)
    ))

(defmethod output_cfill  ((obda obj_datainstance) str)
  (let ( (sl  (obj_datainstance-slots obda))
	 (ov  (currout_data2ptr obda))
	 (irk (initrout_rank obda)) 
	 )
    (format str "/*cfill datainstance ~S #~d */~%" (obj_data-comname obda) irk)
    (format str " basilys_assertmsg(\"cfill datainstance ~S #~d\", basilys_magic_discr((" 
	    (obj_data-comname obda) irk)
    (output_ccode ov str)
    (format str " )) == OBMAG_OBJECT);~%")
    (format str " basilys_assertmsg(\"cfill len datainstance ~S #~d\",  ((basilysobject_ptr_t)("
	    (obj_data-comname obda) irk)
    (output_ccode ov str)
    (format str "))->obj_len >= ~d);~%" (length sl))
;    (finish-output str)
    (if sl
	(loop
	 for crk from 0
	 for csl in sl
	 when csl		       ;don't bother filling nil slots
	 do
;	 (finish-output str)
	 ;; this is a dirty hack, csl should have cold_tempslot_var as
	 ;; destination but some make-obj_datainstance don't do it.
	 ;; if I wanted to code properly I would correct the callers.
	 (or  (get_destination csl) 
	      (let ((ncsl (put_destination csl cold_tempslot_var)))
		(assert ncsl)
		(setq csl ncsl)))
	 (assert (eq (get_destination csl) cold_tempslot_var))
	 (output_ccode csl str)
	 (format str ";~%")
	 (format str "basilys_checked_assign(((basilysobject_ptr_t)(")
	 (output_ccode ov str)
	 (format str ")) ->obj_vartab[~d] = " crk)
	 (output_ccode cold_tempslot_var str)
	 (format str ");~%")
	 ))
    (format str " basilysgc_touch(")
    (output_ccode ov str)
    (format str ");~%")
;    (finish-output str)
    ))

(defmethod output_cdecl ((obj obj_datamultiple) str)
  (let ( (irk (initrout_rank obj)) )
  (format str "/*- decl datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
  (format str " struct BASILYS_MULTIPLE_STRUCT(~d) inidat_~d_;~%" 
	  (my_length_gt_1 (obj_datamultiple-values obj)) irk)
  ))

(defmethod output_cinit ((obj obj_datamultiple) str)
  (let ( (irk (initrout_rank obj)) )
  (format str "/*- init datamultiple ~S #~d-*/~%" (obj_data-comname obj) irk)
   (format str " cdat->inidat_~d_.discr = " irk)
   (output_ccode (obj_data-discr obj) str) 
   (format str ";~%")
   (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_datamultiple-values obj)))
))

(defmethod output_cfill ((obj obj_datamultiple) str)
  (let ( (op (currout_data2ptr obj))
	 (irk (initrout_rank obj))  )
    (format str "/*- fill datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
    (format str " gcc_assert(basilys_magic_discr((")
    (output_ccode op str)
    (format str ")) == OBMAG_MULTIPLE);~%")
    (let ( (nbd  (length  (obj_datamultiple-values obj))) )
      (if (> nbd 0)
	  (progn
	    (format str " gcc_assert(((basilysmultiple_ptr_t)(")
	    (output_ccode op str)
	    (format str "))->nbval >= ~d);~%" nbd))))
;    (finish-output str)
    (loop
     for crk from 0
     for cda in (obj_datamultiple-values obj)
     do
     (format str "((basilysmultiple_ptr_t)(")
     (output_ccode op str)
     (format str "))->tabval[~d] = " crk)
     (output_ccode cda str)
     (format str ";~%")
     )
     (format str " basilysgc_touch(")
     (output_ccode op str)
     (format str ");~%")
;    (finish-output str)
    ))

(defmethod output_cverify ((obda obj_datamultiple) str)	
;  (finish-output str)
  (format str "/*cverify datamultiple ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (format str "gcc_assert(basilys_magic_discr((")
  (output_ccode (currout_data2ptr obda) str)
  (format str ")) == OBMAG_MULTIPLE);~%")
)

(defmethod output_cdecl ((obj obj_datastring) str)
;  (finish-output str)
  (let ( (irk (initrout_rank obj))  )
    (format str "/*- decl datastring ~S #~d -*/~%" (obj_data-comname obj) irk)
    (format str " struct BASILYS_STRING_STRUCT(~d) inidat_~d_;~%" 
      (my_length_gt_1 (obj_datastring-string obj)) irk)
))


(defmethod output_cinit ((obj obj_datastring) str)
;  (finish-output str)
  (let ( (irk (initrout_rank obj))  )
    (format str "/*- init datastring ~S #~d-*/~%" (obj_data-comname obj) irk)
    (format str " cdat->inidat_~d_.discr = " irk)
    (output_ccode (obj_data-discr obj) str) 
    (format str ";~%")
    (format str " strcpy(cdat->inidat_~d_.val, ~s);~%" irk (obj_datastring-string obj))
;    (finish-output str)
    ))

(defmethod output_cfill ((obj obj_datastring) str)
  (finish-output str)
)

(defmethod output_cverify ((obda obj_datastring) str)	
;  (finish-output str)
  (format str "/*cverify datastring ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
  (format str "gcc_assert(basilys_magic_discr((")
  (output_ccode (currout_data2ptr obda) str)
  (format str ")) == OBMAG_STRING);~%")
)

(defstruct (obj_getptrarg_instr (:include obj_instr))
  dest
  rk
)

(defmethod output_ccode ((obj obj_getptrarg_instr) str)
  (format str "/*-*obj_getptrarg_instr*/~%")
  (let ( (dest (obj_getptrarg_instr-dest obj))
	 (rk  (obj_getptrarg_instr-rk obj)) )
    (if (= rk 0) 
	(progn 
	  (format str "basilys_checked_assign(/*ptrarg0*/")
	  (output_ccode dest str)
	  (format str " = firstargp_);")
	  )
      (progn 
	(format str "if (xargdescr_[~d] == BPAR_PTR)~% " (- rk 1))
	(format str "basilys_checked_assign(/*ptrarg~d*/" rk)
	(output_ccode dest str)
	(format str
		" = (xargtab_[~d].bp_aptr)?(*(xargtab_[~d].bp_aptr)):NULL);~% else goto lab_endargs;~%"
		(- rk 1) (- rk 1))
	(format str " gcc_assert(basilys_discr(")
	(output_ccode dest str)
	(format str ")!=NULL);~%")
	)
      )
;    (finish-output str)
    ))

(defstruct (obj_getlongarg_instr (:include obj_instr))
  dest
  rk
)

(defmethod output_ccode ((obj obj_getlongarg_instr) str)
  (format_c_comment str "*obj_getlongarg_instr ~S*~%" obj)
  (let ( (dest (obj_getlongarg_instr-dest obj))
	 (rk  (obj_getlongarg_instr-rk obj)) )
    (if (= rk 0) 
	(error "long arg cannot be first ~S" obj))
    (format str "if (xargdescr_[~d] == BPAR_LONG)~% " (- rk 1))
    (output_ccode dest str)
    (format str " = xargtab_[~d].bp_long;~% else goto lab_endargs;~%"
	    (- rk 1))
;    (finish-output str)
    )
  )


(defstruct (obj_getcstringarg_instr (:include obj_instr))
  dest
  rk
)

(defmethod output_ccode ((obj obj_getcstringarg_instr) str)
  (format_c_comment str "*obj_getcstringarg_instr ~S*~%" obj)
  (let ( (dest (obj_getcstringarg_instr-dest obj))
	 (rk  (obj_getcstringarg_instr-rk obj)) )
    (if (= rk 0) 
	(error "long arg cannot be first ~S" obj))
    (format str "if (xargdescr_[~d] == BPAR_CSTRING)~% " (- rk 1))
    (output_ccode dest str)
    (format str " = xargtab_[~d].bp_cstring;~% else goto lab_endargs;~%"
	    (- rk 1))
;    (finish-output str)
    )
  )


;;; actually an obj_compute may have several destination (for example
;;; for a setq whose value is used)
    
(defstruct (obj_compute (:include obj_instr))
  dest				      ;last destination
  sons					;either strings or expr or atoms
  otype					;type
  compserial				;unique serial number
  )

(defvar compute_serial_count 0)

(defun build_obj_compute (dest sons otype)
  (assert (listp sons))
  (if (some (function prog_src-p) sons) 
      (error "build_obj_compute bad sons {prog_src} ~S" sons))
  (if (some (function obj_instr-p) sons) 
      (error "build_obj_compute bad sons {obj_instr} ~S" sons))
  (incf compute_serial_count)
  (make-obj_compute :dest dest 
		    :sons (if dest (append (list dest " = ") sons) sons) 
		    :otype otype :compserial compute_serial_count)
)


;;; set a closed variable
(defstruct (obj_closetq (:include obj_instr))
  cldest				;closed destination
  val)

;;; obj_vars are variables (eg pointers, longs...) in the current stack frame
(defstruct obj_var
  vbind					;the binding defing the program variable
  voffset				;the offset or index in the C frame
  vrout					;the routine containing the variable
  vwhy					;the reason why this stuff has been made
  vfree					;set when freed in the curframe
);; obj_ptrvar & obj_longvar are actually the relevant subclasses see
;; also obj_closedvar (for variables in closures), obj_routconst (for
;; constants inside routines), obj_initdata (for data in the initialization routine)

(defmethod output_ccode ((obj obj_var) str)
  (error "output_ccode obj_var ~s" obj)
)

(defmethod put_destination ((obj obj_var) dest)
  (build_obj_compute
   dest
   (list obj)
   (cond ((obj_ptrvar-p obj) :value)
	 ((obj_longvar-p obj) :long)
	 (t (error "put_destination obj strangevar ~S dest ~S" obj dest)))
   ))


(defmethod output_ccode ((obj obj_compute) str)
  (format str "/* obj_compute.#~d */~%" (obj_compute-compserial obj))
  (let ( (dest (obj_compute-dest obj)) )
   (cond ((null dest)
	  (format str " (void) ("))
	 ((obj_ptrvar-p dest) (format str "basilys_checked_assign(/*comput*/")))
    (mapc (lambda (s) (cond 		;order matters here!
		       ( (stringp s) (format str "~a" s) )
		       ( (integerp s) (format str "~d" s) )
		       ( (null s) (format str "/*coputenil*/NULL") )
		       ( (symbolp s)
			 (format str "(/*compute symb*/BASILYSG(~S))" s) )
		       ( (or (obj_instr-p s) (obj_var-p s) (obj_data-p s)
			     (obj_closedvar-p s) 
			     (obj_routconst-p s) (obj_verbatim-p s)
			     (obj_cstring-p s)
			     )		;before the atom test!
			 (output_ccode s str) )
		       ( (atom s) 
			 (format str "(/*compute son [~S]*/~s)" (type-of s) s) )
		       ( t (error "output_ccode obj_compute ~s !!invalid son ~s" obj s))))
	  (obj_compute-sons obj))
    (cond  ((null dest)
	    (format str ");~%"))
	   ((obj_ptrvar-p dest) (format str ");~%"))
	   ((obj_longvar-p dest) (format str ";~%"))
	   )
    ))


(defmethod put_destination ((obj obj_compute) dest)
  (let ( (otyp (obj_compute-otype obj)) 
	 (destyp  (query_ctype dest))
	 )
    (cond  (  (eq ':void otyp)
	      (let ( (nblo (make-obj_block :instrs (list obj (make-obj_verbatim :vstr "/*Void*/NULL")))) )
		(put_destination nblo dest))
	      )
	   (
	    (or (null otyp) (null destyp) (eq otyp destyp))
	    (setf (obj_compute-sons obj) (append (list dest " = ") (obj_compute-sons obj)))
	    (setf (obj_compute-dest obj) dest)
	    nil)
	   (t 
	    (make-obj_block :instrs 
			    (list 
			     obj
			     (make-obj_verbatiminstr :vstr (format nil "/*incompatible put_destination dest ~S otyp ~S*/" dest otyp))
			     (build_obj_compute
			      dest
			      (case otyp 
				(:long (list (make-obj_verbatim :vstr "/*incompatput:long*/0L")))
				(:value (list (make-obj_verbatim :vstr "/*incompatput:value*/(void*)0")))
				(otherwise (list (make-obj_verbatim :vstr (format nil "/*incompatput- ~S */0" otyp))))
				)
			      otyp
			      )
			     ))))))

(defmethod get_destination ((obj obj_compute))
   (obj_compute-dest obj)
)

(defstruct (obj_ptrvar (:include obj_var)))

(defstruct (obj_longvar (:include obj_var)))

(defstruct (obj_cstringvar (:include obj_var)))

(defmethod  print-object ((ov obj_ptrvar) st)
  (if (cold_any_binding-p (obj_ptrvar-vbind ov))
      (format st "ObjPtrVar@~d/~S?~S" 
	      (obj_ptrvar-voffset ov) 
	      (cold_any_binding-bname (obj_ptrvar-vbind ov))
	      (obj_ptrvar-vwhy ov)
	      )
      (call-next-method ov st)
))

(defmethod  print-object ((ov obj_longvar) st)
  (if (cold_any_binding-p (obj_longvar-vbind ov))
      (format st "ObjLongVar@~d/~S?~S" 
	      (obj_longvar-voffset ov) 
	      (cold_any_binding-bname (obj_longvar-vbind ov))
	      (obj_longvar-vwhy ov)
	      )
      (call-next-method ov st)
      ))


(defmethod  print-object ((ov obj_cstringvar) st)
  (if (cold_any_binding-p (obj_cstringvar-vbind ov))
      (format st "ObjCstringVar@~d/~S?~S" 
	      (obj_cstringvar-voffset ov) 
	      (cold_any_binding-bname (obj_cstringvar-vbind ov))
	      (obj_cstringvar-vwhy ov)
	      )
      (call-next-method ov st)
      ))


(defconstant cold_return_var
  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_RETVAL_ :type :value) 
		   :voffset 0))

(defconstant cold_tempslot_var
  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_TMPSLOT_ :type :value) 
		   :voffset 1))

(defconstant cold_tempnum_var
  (make-obj_longvar :vbind (make-cold_typed_binding :bname '_TMPNUM_ :type :long) 
		   :voffset 0))


(defmethod output_ccode ((obj obj_ptrvar) str)
  (let ((b (obj_var-vbind obj))
	(o (obj_var-voffset obj)))
    (if b (format str "/*~S ? ~S*/" (cold_any_binding-bname b)
		  (obj_var-vwhy obj)
		  )
      (format str "/*??~S*/" (obj_var-vwhy obj)))
    (format str "curfptr[~d]" o)
    )
)

(defmethod query_ctype ((obj obj_ptrvar))
':value)



(defmethod output_ccode ((obj obj_cstringvar) str)
  (let ((b (obj_var-vbind obj))
	(o (obj_var-voffset obj)))
    (if b (format str "/*~S ? ~S*/" (cold_any_binding-bname b)
		  (obj_var-vwhy obj)
		  )
      (format str "/*??~S*/" (obj_var-vwhy obj)))
    (format str "curfram__.varcstring[~d]" o)
    )
)

(defmethod query_ctype ((obj obj_cstringvar))
':cstring)

(defmethod query_ctype ((obj string))
':cstring)



(defmethod query_ctype ((obj obj_compute))
  (obj_compute-otype obj))

(defmethod output_ccode ((obj obj_longvar) str)
  (let ((b (obj_var-vbind obj))
	(o (obj_var-voffset obj)))
    (if b (format str "/*~S ? ~S*/" 
		  (cold_any_binding-bname b)
		  (obj_var-vwhy obj)
		  )
      (format str "/*??~S*/" (obj_var-vwhy obj)))
    (format str "curfnum[~d]" o)
    )
  )


(defmethod output_ccode ((obj obj_closetq) str)
  (let ((d (obj_closetq-cldest obj))
	(s (obj_closetq-val obj)))
    (or (obj_closedvar-p d) 
	(error "not closedvar in obj_closetq ~S~%" obj))
    (format str "/*closetq*/ {~% void* d = ")
    (output_ccode d str)
    (format str " = ")
    (output_ccode s str)
    (format str ";~%")
    (format str "basilysgc_touch_dest(curfclos, d); }~%")
))

(defmethod query_ctype ((obj obj_longvar))
':long)

(defmethod query_ctype ((obj integer))
':long)

(defstruct obj_closedvar
  cvar					;the name of the closed variable
  cfun					;the function of the closure
  coffset				;the offset inside the closure
)

(defmethod put_destination ((obj obj_closedvar) dest)
  (build_obj_compute
   dest
   (list obj)
   :value
   ))

(defmethod output_ccode ((obj obj_closedvar) str)
  (format str "/*clovar ~s*/ curfclos->tabval[~d]" 
	  (obj_closedvar-cvar obj) (obj_closedvar-coffset obj))
)

(defstruct obj_routconst
  krout					;the routine quoting this constant
  kval					;the value of the constant
  koffset 				;the offset inside the function
  kwhy					;string why
)


(defun newobjconst (val &optional why)
  (let 
      ( (curout (compilation-currout this_compilation) )
	)
    (assert (obj_data-p val) (val) "non-data values for newobjconst ~S" val)
    (if (and (obj_routine-p curout) (not (obj_initroutine-p curout)))
	;; usual case, we are in some routine
	(let 
	    ( (datarout (obj_routine-datarout curout)) )
	  (or (obj_dataroutine-p datarout) 
	      (error "newobjconst bad datarout ~S in curout ~S~%" datarout curout))
	  (let ( (off (position val (obj_dataroutine-roudata datarout)))
		 (ln (length (obj_dataroutine-roudata datarout))) )
	    (if off 
		(progn
		  ;;(warn "newobjconst val=~S found off=~S ln=~S~%" val off ln)
		  (make-obj_routconst :krout curout 
				       :kval val 
				       :koffset (- ln off 1)
				       :kwhy why
				       )
		  )
	      (let ( (ln (length (obj_dataroutine-roudata datarout))) )
		(push val (obj_dataroutine-roudata datarout))
		(let ( (newconst (make-obj_routconst :krout curout :kval val :koffset ln :kwhy why)) )
		  newconst
		  )
		))))
      ;; otherwise it is a global data 
      (progn
	(if  (null (currout_data2ptr val)) 
	    (add_cdata val (concatenate 'string "newobjconst-" (string why)))
	  val)
	)
      )))


(defmethod output_ccode ((obj obj_routconst) str)
  (let ((kval (obj_routconst-kval obj))
	(kwhy (obj_routconst-kwhy obj))
	)
    (cond ( (symbolp kval)
	    (format str "/*constsymb ~S ? ~S*/" kval kwhy) )
	  ( (obj_data-p kval)
	    (format str "/*const[~S] ~S ? ~S*/" 
		    (type-of kval) (obj_data-comname kval) kwhy)
	    )
	  ( t
	    (format str "/*const/ty[~S] ? ~S*/" (type-of kval) kwhy)))
    (format str "curfrout->tabval[~d]"
	    (obj_routconst-koffset obj))
    ))


(defstruct (obj_mkclosure (:include obj_instr))
  dest 					;optional destination
  cfun					;closure function
  cvals					;closed values
  kobjrout				;closure object routine constant
)

(defmethod put_destination ((obj obj_mkclosure) dest)
  (setf (obj_mkclosure-dest obj) dest)
  nil
)

(defmethod get_destination ((obj  obj_mkclosure))
  (obj_mkclosure-dest obj)
)

(defmethod output_ccode ((obj obj_mkclosure) str)
  (format str "{")
  ;(format_c_comment str "**mkclosure ~S ~%**~%" obj)
  (let ( ( cvals (obj_mkclosure-cvals obj))
	 ( dest (obj_mkclosure-dest obj))
	 ( cfun (obj_mkclosure-cfun obj))
	 ( kobjrout (obj_mkclosure-kobjrout obj))
	 )
    (format str " struct BASILYS_CLOSURE_STRUCT(~d) *newclos_=0;~%"
	    (my_length_gt_1 cvals))
    (format str " newclos_ = basilysgc_allocate(sizeof(*newclos_),0);~%")
    (format str " newclos_->discr = (void*)BASILYSG(DISCR_CLOSURE);~%")
    (format str " newclos_->nbval = ~d;~%"  (length cvals))
    (if dest
	(progn (output_ccode dest str) (format str " = (void*)newclos_;~%")))
    (format str " newclos_->rout = ")
    (output_ccode kobjrout str)
    (format str ";~%")
    (loop
      for crk from 0
      for cva in cvals
      do
      (format str "newclos_->tabval[~d] = " crk)
      (output_ccode cva str)		;
      (format str ";~%")
      )
    )
  (format str "}/**end mkclosure*/~%")
;  (finish-output str)
  )

(defstruct (obj_block (:include obj_instr))
  instrs)

(defmethod output_ccode ((obj obj_block) str)
  (let ((instrs (obj_block-instrs obj)))
    (format str "{~%")
    (mapc (lambda (i) 
	    (if (obj_instr-p i) 
		(progn 
		  (output_ccode i str) (format str ";~%"))))
	  instrs)
    (format str "}~%")
;    (finish-output str)
))

(defmethod query_ctype ((obj obj_block))
  (let ((lastinstr (last (obj_block-instrs obj))))
    (and lastinstr (query_ctype (first lastinstr))))
)

(defmethod put_destination ((obj obj_block) dest)
  (let ((instrs (obj_block-instrs obj)))
    (let ( (l (last instrs) ))
      (if (consp l) 
	  (let ( (nd (put_destination (first l) dest)) )
	    (if nd (setf (first l) nd))
	    )
      ))
    nil
    ))

(defmethod get_destination ((obj obj_block))
  (let ((instrs (obj_block-instrs obj)))
    (let ( (l (last instrs) ))
      (if (consp l) (get_destination (first l))))))
  

(defstruct (obj_if (:include obj_instr))
  ob_cond ob_then ob_else)

(defmethod output_ccode ((obj obj_if) str)
  (let ( (ocond (obj_if-ob_cond obj))
	 (othen (obj_if-ob_then obj))
	 (oelse (obj_if-ob_else obj)) )    
    (format str "{ /*if*/~%")
    (if (obj_instr-p ocond) (error "too complex (objinstr) cond in obj_if ~S" obj))
    (format str " if (")
    (output_ccode ocond str)
    (format str ") {/*then*/~%")
    (output_ccode othen str)
    (if oelse 
	(progn
	  (format str "} else {~%")
	  (output_ccode oelse str)
	  (format str "}~%"))
      (format str "}/*noelse*/;~%"))
    (format str "} /*endif*/~%")
))


(defmethod query_ctype ((obj obj_if))
  (let ( (ocond (obj_if-ob_cond obj))
	 (othen (obj_if-ob_then obj))
	 (oelse (obj_if-ob_else obj)) )    
    (let ( (tythen (query_ctype othen)))
      (if oelse
	  (and (eq (query_ctype oelse) tythen) tythen)
	tythen)
)))



(defmethod put_destination ((obj obj_if) dest)
  (let ( (ocond (obj_if-ob_cond obj))
	 (othen (obj_if-ob_then obj))
	 (oelse (obj_if-ob_else obj)) )
;    (and othen (get_destination othen) oelse (get_destination oelse)
;	 (error "obj_if ~S already got destination in ~S" 
;		obj (obj_routine-syname (compilation-currout this_compilation))))
    (let ((dthen (put_destination othen dest))
	  (delse (if oelse (put_destination oelse dest) 
		   (build_obj_compute dest (list "NULL") (query_ctype othen)))))
      (if dthen (setf (obj_if-ob_then obj) dthen))
      (if delse (setf (obj_if-ob_else obj) delse))
      )
    nil
))


(defmethod get_destination  ((obj obj_if))
  (let ( (ocond (obj_if-ob_cond obj))
	 (othen (obj_if-ob_then obj))
	 (oelse (obj_if-ob_else obj)) )
    (if oelse
	(and (eq (get_destination othen) (get_destination oelse))
	     (get_destination othen))
      (get_destination othen)
    )))



;;;;;;;;;;; calls & sends

;;;; calls
(defstruct (obj_call (:include obj_instr))
  dest					;main destination
  clos					;called closure
  xtraresults				;other results
  args					;arguments
  )



(defmethod output_ccode ((obj obj_call) str)
  (let* ( (dest (obj_call-dest obj))
	  (clos (obj_call-clos obj))
	  (xresults (obj_call-xtraresults obj))
	  (argseq (obj_call-args obj)) 
	  (arg1 (and (consp argseq) (car argseq))) 
	  (revargtypeseq nil)
	  (revrestypeseq nil)
	  (oargs (and (consp argseq) (cdr argseq)))
	  )
    (format str "/*-*call:*/~%{" obj)
    (if xresults
	(format str " union basilysparam_un restab[~d];~%" (length xresults)))
    (if oargs
	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
    (if xresults
	(format str " memset(restab, 0, sizeof(restab));~%"))
    (if oargs
	(format str " memset(argtab, 0, sizeof(argtab));~%"))
    (loop for ark from 0 for arg in oargs do
	  (case (query_ctype arg)
		(:long 
		 (format str " argtab[~d].bp_long = " ark)
		 (output_ccode arg str)
		 (push "BPARSTR_LONG" revargtypeseq)
		 (format str ";~%")
		 )
		(:cstring 
		 (format str " argtab[~d].bp_cstring = " ark)
		 (output_ccode arg str)
		 (push "BPARSTR_CSTRING" revargtypeseq)
		 (format str ";~%")
		 )
		((:value nil) 
		 (if arg 
		     (progn
		       (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
		       (output_ccode arg str)
		       (push "BPARSTR_PTR" revargtypeseq)
		       (format str ");~%"))
		   (format str " argtab[~d].bp_aptr /*nil arg*/ = NULL;~%")))
		(otherwise (error "output_ccode obj_call cannot handle arg ~s in ~s" arg obj)))
	  )
    (loop for resrk from 0 for xres in xresults do
	  (case (query_ctype xres)
		(:long (format str " restab[~d].bp_longptr = & (" resrk)
		       (output_ccode xres str)
		       (push "BPARSTR_LONG" revrestypeseq)
		       (format str ");~%"))
		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
		 (output_ccode xres str)
		 (push "BPARSTR_PTR" revrestypeseq)
		 (format str ");~%"))
		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
	  )
    (cond
     ((obj_ptrvar-p dest) 
      (format str "/*ptrappl*/ basilys_checked_assign(")
      (output_ccode dest str)
      (format str " = "))
     ((null dest)
      (format str "/*nodestappl*/ (void) "))
     (dest
      (assert (not (obj_longvar-p dest)) (dest obj) "output_ccode objcall dest ~S obj ~S" dest obj)
      (format str "/*noptrappl*/")
      (output_ccode dest str)
      (format str " = "))
     )
    (format str "basilys_apply(((void*)(")
    (output_ccode clos str)
    (format str ")), (")
    (output_ccode arg1 str)
    (format str "),~%   (")
    (loop for argtype in (reverse revargtypeseq) do 
	  (format str " ~a" argtype))
    (format str " \"\"), ")
    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
    (format str ", ~%  (")
    (loop for restype in (reverse revrestypeseq) do 
	  (format str " ~a" restype))
    (format str " \"\"), ")
    (if xresults (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
    (if
	(obj_ptrvar-p dest)
	(format str "));~%")
      (format str ");~%"))
    (format str "~%} /*endcall*/ ~%")
					;    (finish-output str)
    )
  )

(defmethod put_destination ((obj obj_call) dest)
  (setf (obj_call-dest obj) dest)
  nil
)

(defmethod get_destination ((obj obj_call))
  (obj_call-dest obj)
)



;;;; sends
(defstruct (obj_send (:include obj_instr))
  obs_dest					;main destination result
  obs_sel					;selector
  obs_xtraresults				;other results
  obs_recv					;reciever
  obs_args					;arguments
  )


(defmethod output_ccode ((obj obj_send) str)
  (let ( (odest (obj_send-obs_dest obj))
	 (osel (obj_send-obs_sel obj))
	 (oxtrares (obj_send-obs_xtraresults obj))
	 (orecv (obj_send-obs_recv obj))
	 (oargs (obj_send-obs_args obj)) 
	 (revargtypeseq nil)
	 (revrestypeseq nil)
	 )
    (format str "/*-*send:*/~%{" obj)
    (if oxtrares
	(format str " union basilysparam_un restab[~d];~%" (length oxtrares)))
    (if oargs
	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
    (if oxtrares
	(format str " memset(restab, 0, sizeof(restab));~%"))
    (if oargs
	(format str " memset(argtab, 0, sizeof(argtab));~%"))
    (loop for ark from 0 for arg in oargs do
	  (case (query_ctype arg)
		(:long
		 (format str " argtab[~d].bp_long = " ark)
		 (output_ccode arg str)
		 (push "BPARSTR_LONG" revargtypeseq)
		 (format str ";~%")
		 )
		(:cstring 
		 (format str " argtab[~d].bp_cstring = " ark)
		 (output_ccode arg str)
		 (push "BPARSTR_CSTRING" revargtypeseq)
		 (format str ";~%")
		 )
		((:value nil) 
		 (if arg 
		     (progn
		       (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
		       (output_ccode arg str)
		       (push "BPARSTR_PTR" revargtypeseq)
		       (format str ");~%"))
		   (progn
		     (format str " argtab[~d].bp_aptr = /*nilarg*/NULL;~%")
		     )))
		(otherwise (error "output_ccode obj_callcannot handle arg ~s in ~s" arg obj)))
	  )
    (loop for resrk from 0 for xres in oxtrares do
	  (case (query_ctype xres)
		(:long (format str " restab[~d].bp_longptr = & (" resrk)
		       (output_ccode xres str)
		       (push "BPARSTR_LONG" revrestypeseq)
		       (format str ");~%"))
		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
		 (output_ccode xres str)
		 (push "BPARSTR_PTR" revrestypeseq)
		 (format str ");~%"))
		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
	  )
    (if odest
	(progn 
	  (output_ccode odest str)
	  (format str " = "))
      (format str "(void) "))
    (format str "basilysgc_send(((void*)(")
    (output_ccode orecv str)
    (format str ")), (")
    (output_ccode osel str)
    (format str "),~%   (")
    (loop for argtype in (reverse revargtypeseq) do 
	  (format str " ~a" argtype))
    (format str " \"\"), ")
    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
    (format str ", ~%  (")
    (loop for restype in (reverse revrestypeseq) do 
	  (format str " ~a" restype))
    (format str " \"\"), ")
    (if oxtrares (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
    (format str ");~%")
    (format str "~%} /*endsend*/ ~%")
					;    (finish-output str)
    ))


(defmethod put_destination ((obj obj_send) dest)
  (setf (obj_send-obs_dest obj) dest)
  nil
)

(defmethod get_destination ((obj obj_send))
  (obj_send-obs_dest obj)
)

;;;;;;;;;;; forever instruction

(defstruct (obj_forever (:include obj_instr))
  obforever_bind					;forever binding
  obforever_res					;result
  obforever_dest					;forever destination
  obforever_body					;body
  obforever_epilogue			;epilogue
  )

(defmethod put_destination ((obj obj_forever) dest)
  (setf (obj_forever-obforever_dest obj) dest)
  nil
)

(defmethod get_destination ((obj obj_forever))
  (obj_forever-obforever_dest obj)
)


(defmethod output_ccode ((obj obj_forever) str)
  (let* ( (lbind (obj_forever-obforever_bind obj))
	  (lres  (obj_forever-obforever_res obj))
	  (ldest (obj_forever-obforever_dest obj))
	  (lepil (obj_forever-obforever_epilogue obj))
	  (lbody (obj_forever-obforever_body obj)) 
	  (luniq (cold_forever_binding-uniq lbind))
	  )
    (format str "/*forever ~S*/{~%" luniq)
    (output_ccode lres str)
    (format str " = 0;~%")
    (format str " lab_startforever_~a:;~%" (string luniq))
    (loop for rk from 1 for ins in lbody do
	  (format str "/*forever ~S instr#~d*/" luniq rk)
	  (output_ccode ins str)
	  (format str ";~%"))
    (format str "/*againforever*/ goto lab_startforever_~a;~%" (string luniq))
    (format str " lab_endforever_~a:;~%" (string luniq))
    (if ldest 
	(progn
	  (format str "/*foreverdest ~S*/~%" luniq)
	  (output_ccode ldest str)
	  (format str " = ")
	  (output_ccode lres str)
	  (format str ";~%")
	  ))
    (if lepil
	(progn
	  (format str "/*foreverdest ~S*/~%" lepil)
	  (output_ccode lepil str)
	  (format str ";~%")
	  ))
    (format str "/*endforever ~S*/}~%" luniq)
;    (finish-output str)
    ))
		
;;;;

(defstruct (obj_exit (:include obj_instr))
  obxit_bind 
  obxit_body
)

(defmethod put_destination ((obj obj_exit) dest)
  nil
)

(defmethod output_ccode ((obj obj_exit) str)
  (let ( (xuniq (cold_forever_binding-uniq (obj_exit-obxit_bind obj))) )
    (format str "{ /*Exit ~S*/~%" xuniq)
    (loop for irk from 1
	  for ins in (obj_exit-obxit_body obj)
	  do
	  (format str "/*exiting ~S ins#~d*/~%" xuniq irk)
	  (output_ccode ins str)
	  (format str ";~%"))
    (format str " /*exitjump*/ goto lab_endforever_~a;~%" (string xuniq))
    (format str "} /*end Exit ~S*/~%" xuniq)
))

;;;;;;;;;;; return instruction
(defstruct (obj_return (:include obj_instr))
  mainreturn				;the main returned value
  extrareturns				;the sequence of extra returned values
)

(defmethod put_destination ((obj obj_return) dest)
  (let ((nmd (put_destination (obj_return-mainreturn obj) dest))) 
    (if nmd (setf (obj_return-mainreturn obj) nmd))
    ))


(defmethod output_ccode ((obj obj_return) str)
  (format str "/*-*Returning**/ {~%")
  (format_c_comment str "objreturn ~s" obj)
  (let ( 
	(mainret (obj_return-mainreturn obj))
	(xtrarets (obj_return-extrareturns obj))
	)
    (if (null mainret) 
	(format str "/*no retval*/ curfptr[0] = (void*)0 ")
      (let ( (maindest (get_destination mainret)) )
	(format_c_comment str "mainret ~S maindest ~S" mainret maindest)
	(if (not (eq maindest cold_return_var))
	    (format str "/*simple retval*/ curfptr[0] = ")
	  (format str "/*got retval*/ "))
	(output_ccode mainret str)
	))
    (format str ";~%")
    (if xtrarets 
	(format str " if (!xrestab_ || !xresdescr_) goto lab_endrout;~%"))
    (loop
     for ark from 0
     for ret in xtrarets 
     do
     (format_c_comment str "*!* extra result #~d = ~s *~%" ark ret)
     (let ( (rettype (query_ctype ret)) )
       (case rettype
	     (:long 
	      (format str " if (xresdescr_[~d] != BPAR_LONG) goto lab_endrout;~%" ark)
	      (format str " if (xrestab_[~d].bp_longptr)~%     *(xrestab_[~d].bp_longptr) = (" ark ark)
	      (output_ccode ret str)
	      (format str ");~%")
	      )
	     ((:value nil) 
	      (format str " if (xresdescr_[~d] != BPAR_PTR) goto lab_endrout;~%" ark)
	      (format str " if (xrestab_[~d].bp_aptr)~%     *(xrestab_[~d].bp_aptr) = (void*) (" ark ark)
	      (output_ccode ret str)
	      (format str ");~%")
	      )
	     (otherwise (error "bad return type ~s in ~s" rettype obj))
	     )
       )))
  (format str " goto lab_endrout;~%")
  (format str "} /*end return*/~%")
;  (finish-output str)
  )


(defstruct (obj_routine (:include obj_instr))
  pfun					;prog function
  syname				;symbol for easier naming it (or nil)
  rank					;integer rank of this function
  obody					;sequence of C instr
  nbptr					;total number of pointer variables
  nbnum					;total number of long variables
  nbdouble				;total number of double variables
  nbcstring				;total number of cstring variables
  freevptrs				;list of free varptr to be reused
  freevnums				;list of free varlong to be reused
  freevdbls				;list of free vardbl to be reused
  freevcstrings				;list of free varcstring to be reused
  dataclos				;the associated dataclosure
  datarout				;the associated dataroutine
  data2ptrhash				;hash associating data to pointers
)

(defmethod  print-object ((ob obj_routine) st)
  (format st "ObjRoutine{SyName=~S Obody=~S DataClos=~S DataRout=~S}" 
	  (obj_routine-syname ob)
	  (obj_routine-obody ob)
	  (obj_routine-dataclos ob)
	  (obj_routine-datarout ob)
	  ))


(defun routine_link_data2ptr (orout odata ptr)
  (assert (obj_routine-p orout))
  (assert (obj_data-p odata))
  (assert ptr)
  (setf (gethash odata (obj_routine-data2ptrhash orout)) ptr)
)

(defun routine_get_ptr4data (orout odata)
  (assert (obj_routine-p orout))
  (assert (obj_data-p odata)) 
  (gethash odata (obj_routine-data2ptrhash orout))
)

(defun currout_data2ptr (odata)
  (assert (obj_data-p odata))
  (let ( (currout
	  (or (compilation-currout this_compilation)
	      (compilation-initrout this_compilation))) )
    (assert (obj_routine-p currout))
    (routine_get_ptr4data currout odata)
))

(defun currout_link_data2ptr (odata ptr)
  (assert (obj_data-p odata))
  (let ( (currout
	  (or (compilation-currout this_compilation)
	      (compilation-initrout this_compilation))) )
    (assert (obj_routine-p currout)) 
    (routine_link_data2ptr currout odata ptr)
))

(defun routinecname (rou) 
  (if (obj_routine-p rou)
      (let ( (rk (obj_routine-rank rou))
	     (sn (obj_routine-syname rou)) )
	(if (symbolp sn)
	    (let ( (tsn (map 'string (lambda (c) (if (alphanumericp c) c #\_)) (symbol-name sn))) )
	      (format nil "rout__~d__~a" rk tsn))
	  (format nil "rout__~d" rk)))))

(defmethod output_ccode ((obj obj_routine) str)
  (let ( (rk (obj_routine-rank obj)) 
	 (nbptr (obj_routine-nbptr obj))
	 (nbnum (obj_routine-nbnum obj))
	 (nbdouble (obj_routine-nbdouble obj))
	 (nbcstring (obj_routine-nbcstring obj))
	 (oldcurout (compilation-currout this_compilation))
	 )
    (setf (compilation-currout this_compilation) obj)
    (format str "~%~% /*** C routine ~d <~S> **/~%" rk (obj_routine-syname obj))
    ;; (format_c_comment str "** routine ~S ~& routine rank ~d  **~%" obj rk)
    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
    (format str "     	     basilys_ptr_t firstargp_,~%")
    (format str "	    	     const char xargdescr_[],~%")
    (format str "              union basilysparam_un* xargtab_,~%")
    (format str "              const char xresdescr_[],~%")
    (format str "              union basilysparam_un* xrestab_)~%{~%")
    (format str "#if ENABLE_CHECKING~%")
    (format str "  static long thiscallcounter__;~%")
    (format str "  long callcount_ = ++thiscallcounter__;~%")
    (format str "#define callcount callcount_~%")
    (format str "#else~%")
    (format str "#define callcount 0L~%")
    (format str "#endif~%")
    (format str "  struct {~%")
    (format str "    unsigned nbvar;~%")
    (format str "#if ENABLE_CHECKING~%")
    (format str "  const char* flocs;~%")
    (format str "#endif~%")
    (format str "    struct basilysclosure_st* clos;~%")
    (format str "    struct excepth_basilys_st* exh;~%")
    (format str "    struct callframe_basilys_st* prev;~%")
    (format str "    void* varptr[COLD_EXTRAGAP+ ~d];~%" (+ nbptr 1))
    (format str "    long varnum[COLD_EXTRAGAP+ ~d];~%" (+ nbnum 1))
    (format str "    double vardbl[COLD_EXTRAGAP+ ~d];~%" (+ nbdouble 1))
    (format str "    const char* varcstring[COLD_EXTRAGAP+ ~d];~%" (+ nbcstring 1))
    (format str "    long _spare_;~%")
    ;; @@@ the real nbvar should be nbptr but we have a bug somewhere...
    (format str "  } curfram__ = { /*nbvar*/~d,~%" (+ nbptr 1)) 
    (format str "#if ENABLE_CHECKING~%")
    (format str "  (char*)0,~%")
    (format str "#endif~%")
    (format str "   (struct basilysclosure_st*)0,~%")
    (format str "   (struct excepth_basilys_st*)0,~%")
    (format str "   (struct callframe_basilys_st*)0, ~%")
    (progn 
      (format str "/*~d ptrvars:*/ {" nbptr)
      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
      (format str "}, ~%")
      ) 
    (progn 
      (format str "/*~d numvars:*/ {" nbnum)
      (loop for ix from 1 to nbnum do (format str " 0L,"))
      (format str " 0L }, ~%")
      )
    (progn 
      (format str "/*~d doublevars:*/ {" nbdouble)
      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
      (format str " 0.0 }, ~%")
      )
    (format str " 0L };~% curfram__.prev = (void*)basilys_topframe;~%")
    (format str " curfram__.clos = closp_;~%")
    (format str " basilys_topframe= (void*)(&curfram__);~%")
    (format str "/* body ~d start */~%" rk)
    (format str "basilys_check_call_frames(BASILYS_ANYWHERE, \"start ~a\");~%" (routinecname obj))
    (output_ccode (obj_routine-obody obj) str)
    (format str "/* body ~d end */~%" rk)
    (format str " lab_endrout:~%") 
    (format str "basilys_check_call_frames(BASILYS_ANYWHERE, \"end ~a\");~%" (routinecname obj))
    (format str " basilys_topframe= (void*)(curfram__.prev); return curfram__.varptr[0];~%")
    (format str "#undef callcount~%")
    (format str "} /* end rout_~d */~%~%" rk)
    (setf (compilation-currout this_compilation) oldcurout)
    (finish-output str)
    ))



(defmethod output_cdecl ((obj obj_routine) str)
  (let ((rk (obj_routine-rank obj)))
    (format str "~%/** declroutine routine rank ~d  **/~%" 
	    rk)
    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
    (format str "     	     basilys_ptr_t firstargp_,~%")
    (format str "	    	     const char xargdescr_[],~%")
    (format str "              union basilysparam_un* xargtab_,~%")
    (format str "              const char xresdescr_[],~%")
    (format str "              union basilysparam_un* xrestab_);~%")
    ))


;; make a pointer variable inside a routine, using the free list if possible
;; orout is the object routine inside which it is used
;; bind is the binding
;; why is some explanation string
(defun newobjptrvar (orout bind why)
  (assert (obj_routine-p orout))
  (assert (cold_any_binding-p bind))
  (if why (assert (stringp why)))
  (if (consp (obj_routine-freevptrs orout))
      (let ( (fvar (pop (obj_routine-freevptrs orout))) )
	(assert (obj_ptrvar-p fvar))
	(assert (obj_var-vfree fvar))
	(assert (eq (obj_var-vrout fvar) orout))
	;; don't reuse fvar for ease of debugging but make a new var of same offset
	(let ( (rvar (copy-obj_ptrvar fvar)) )
	  (setf (obj_var-vbind rvar) bind)
	  (setf (obj_var-vwhy rvar) why)
	  (setf (obj_var-vfree fvar) rvar)
	  (setf (obj_var-vfree rvar) nil)
	  rvar
	))
    (let ( (nvar (make-obj_ptrvar :vbind bind 
				  :voffset (incf (obj_routine-nbptr orout))
				  :vwhy why
				  :vrout orout)) )
      nvar
      )))

;; free a pointer variable to enable its reuse
(defun freeobjptrvar (ovar)
  (assert (obj_ptrvar-p ovar))
  (assert (cold_any_binding-p (obj_var-vbind ovar)))
  (let ( (orout (obj_var-vrout ovar)) 
	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
	 )
    (assert (obj_routine-p orout))
    (push ovar (obj_routine-freevptrs orout))
    (setf (obj_var-vfree ovar) t)
    nil
))


;; make a long variable inside a routine, using the free list if possible
;; orout is the object routine inside which it is used
;; bind is the binding
;; why is some explanation string
(defun newobjlongvar (orout bind why)
  (assert (obj_routine-p orout))
  (assert (cold_any_binding-p bind))
  (if why (assert (stringp why)))
  (if (consp (obj_routine-freevnums orout))
      (let ( (fvar (pop (obj_routine-freevnums orout))) )
	(assert (obj_longvar-p fvar))
	(assert (obj_var-vfree fvar))
	(assert (eq (obj_var-vrout fvar) orout))
	;; don't reuse fvar for ease of debugging but make a new var of same offset
	(let ( (rvar (copy-obj_longvar fvar)) )
	  (setf (obj_var-vbind rvar) bind)
	  (setf (obj_var-vwhy rvar) why)
	  (setf (obj_var-vfree fvar) rvar)
	  (setf (obj_var-vfree rvar) nil)
	  rvar
	))
    (let ( (nvar (make-obj_longvar :vbind bind 
				  :voffset (incf (obj_routine-nbnum orout))
				  :vwhy why
				  :vrout orout)) )
      nvar
      )))

;; free a long variable to enable its reuse
(defun freeobjlongvar (ovar)
  (assert (obj_longvar-p ovar))
  (assert (cold_any_binding-p (obj_var-vbind ovar)))
  (let ( (orout (obj_var-vrout ovar)) 
	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
	 )
    (assert (obj_routine-p orout))
    (push ovar (obj_routine-freevnums orout))
    (setf (obj_var-vfree ovar) t)
    nil
))


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

;; make a cstring variable inside a routine, using the free list if possible
;; orout is the object routine inside which it is used
;; bind is the binding
;; why is some explanation string
(defun newobjcstringvar (orout bind why)
  (assert (obj_routine-p orout))
  (assert (cold_any_binding-p bind))
  (if why (assert (stringp why)))
  (if (consp (obj_routine-freevcstrings orout))
      (let ( (fvar (pop (obj_routine-freevnums orout))) )
	(assert (obj_cstringvar-p fvar))
	(assert (obj_var-vfree fvar))
	(assert (eq (obj_var-vrout fvar) orout))
	;; don't reuse fvar for ease of debugging but make a new var of same offset
	(let ( (rvar (copy-obj_cstringvar fvar)) )
	  (setf (obj_var-vbind rvar) bind)
	  (setf (obj_var-vwhy rvar) why)
	  (setf (obj_var-vfree fvar) rvar)
	  (setf (obj_var-vfree rvar) nil)
	  rvar
	))
    (let ( (nvar (make-obj_cstringvar :vbind bind 
				  :voffset (incf (obj_routine-nbnum orout))
				  :vwhy why
				  :vrout orout)) )
      nvar
      )))

;; free a cstring variable to enable its reuse
(defun freeobjcstringvar (ovar)
  (assert (obj_cstringvar-p ovar))
  (assert (cold_any_binding-p (obj_var-vbind ovar)))
  (let ( (orout (obj_var-vrout ovar)) 
	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
	 )
    (assert (obj_routine-p orout))
    (push ovar (obj_routine-freevcstrings orout))
    (setf (obj_var-vfree ovar) t)
    nil
))


(defgeneric compile_obj (cod env)
  (:documentation "compilation of (any) Basilys code")
)

(defmethod compile_obj ((cod t) env)
  (break "compile_obj t cod ~S~%! env ~S~%!  ~% <<<compilobj t" 
	  cod env)
  cod
)

(defmethod compile_obj ((cod cons) env)
  (error "compile_obj consp cod ~S~%! env ~S~%!  ~% <<<compilobj cons" 
	  cod env)
  cod
)

(defmethod compile_obj ((cod integer) env)
  cod
)

(defmethod compile_obj ((cod string) env)
  cod
)

(defmethod compile_obj ((cod prog_cstring) env)
  (make-obj_cstring :obcstr (prog_cstring-c_str cod))
)

;; the sole init routine has to be a subclass of objoutine to handle
;; appropriately objpointers
(defstruct (obj_initroutine (:include obj_routine))
  inirou_datarankdict			;dictionnary mapping data to its rank
)

;; given a data, returns its integer rank in the initial routine or else nil
(defun initrout_rank (obda)
  (let ( (hrk 
	  (gethash obda 
		  (obj_initroutine-inirou_datarankdict
		   (compilation-initrout this_compilation)))) )
    ; to ease readability of the initrout we try to match the rank
    ; with the varptr index into which it is usually stored
    (if (integerp hrk) (+ hrk 2))
))

(defmethod output_cdecl ((obj obj_initroutine) str)
  (format str  "~%~%/*-* declinitroutine  *-*/~%")
  (format str "void* start_module_basilys(void*modata_);~%")
)


(defmethod output_ccode ((obj obj_initroutine) str)
  (let ( (nbptr (obj_routine-nbptr obj))
	 (nbnum (obj_routine-nbnum obj))
	 (nbdouble (obj_routine-nbdouble obj))
	 (cdata (reverse (compilation-cdata this_compilation)))
	 (oldcurout (compilation-currout this_compilation))
	 )
    (setf (compilation-currout this_compilation) obj)
    ;; (format str "~%~%/*-* initroutine~% ~S  **/~%" obj)
    (format str "~%~%~%~%~%~%/*######### ccode initroutine ############*/~%")
    (format str "void* start_module_basilys(void*modata_) {~%")
    (format str "/*-*cdatalen ~d **/~%" (length cdata))
    (format str " typedef struct cdata_st {~%")
    (loop for rk from 0 for da in cdata do
	  (format str "/*cdata ~d*/~%" rk)
					;(format_c_comment str "**cdata #~d = ~s~%" rk da)
	  (output_cdecl da str)
	  )
    (format str " long _extragap[2];} cdata_t;~%") 
    (format str " cdata_t*cdat=0;~%")
    (format str "  struct {~%")
    (format str "    unsigned nbvar;~%")
    (format str "    struct basilysclosure_st* clos;~%")
    (format str "    struct excepth_basilys_st* exh;~%")
    (format str "    struct callframe_basilys_st* prev;~%")
    (format str "   void* varptr[~d];~%" (+ nbptr 1))
    (format str "    long varnum[~d];~%" (+ nbnum 1))
    (format str "    double vardbl[~d];~%" (+ nbdouble 1))
    (format str "    long _extra_;~%" )
    (format str "  } curfram__ = { /*nbvar*/~d,~%" nbptr)
    (format str "   (struct basilysclosure_st*)0,~%")
    (format str "   (struct excepth_basilys_st*)0,~%")
    (format str "   (struct callframe_basilys_st*)0, ~%")
    (progn 
      (format str "/*~d ptrvars:*/ {" nbptr)
      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
      (format str "}, ~%")
      )
    (if (> nbnum 0) (progn 
      (format str "/*~d numvars:*/ {" nbnum)
      (loop for ix from 1 to nbnum do (format str " 0L,"))
      (format str "}, ~%")
      ))
    (if (> nbdouble 0) (progn 
      (format str "/*~d doublevars:*/ {" nbdouble)
      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
      (format str "}, ~%")
      ))
    (format str " 0L};~% curfram__.prev = basilys_topframe;~%")
    (format str " basilys_topframe= (void*)(&curfram__);~%")
    (format str "/*allocating and assigning cdata*/ {~%;~%")
    (format str " debugeprintf(\"generated cdatlen ~d : size %d bytes\", (int)sizeof(cdata_t));~%" 
	    (length cdata))
    (format str " cdat = basilysgc_allocate(sizeof(cdata_t),0);~%")
    (format str " debugeprintf(\" cdat %p - %p\", (void*)cdat, (void*)((char*)cdat + sizeof(cdata_t)));~%")
    (loop for rk from 0 for da in cdata do
	  (format str "~%/* assign cdata #~d*/~%" rk)
	  (output_cassign da str)	
	  )
    (format str "/***** initcdata ***/~%")
    (loop for rk from 0 for da in cdata do
	  (format str "~%/* init cdata #~d*/~%" rk)
	  (output_cinit da str)	
	  (format str "~%/* endinit cdata #~d*/~%" rk)
	  )
    (format *error-output* ";;wrote ~d init cdata ~g cpusec~%" (length cdata) (cpusec))
    (finish-output str)
    (format str "} /*allocated, assigned, inited cdata*/~%")
    (format str "/*filling cdata ****/~%")
    (loop for rk from 0 for da in cdata do
	  (format str "~%/* fill cdata #~d*/~%" rk)
	  (output_cfill da str)	
	  )
    (finish-output str)
    (format *error-output* ";;wrote ~d fill cdata ~g cpusec~%" (length cdata) (cpusec))
    (format str "/*verifying cdata ****/~%")
    (loop for rk from 0 for da in cdata do
	  (format str "~%/* verify cdata #~d*/~%" rk)
	  (output_cverify da str)	
	  )
    (format str "/*body of initrout*/~%")
    (format *error-output* ";;before writing init body ~g cpusec~%" (cpusec))
    (format str " debugeprintf(\"before init routine body\");~%")
    (if (obj_routine-obody obj)  (output_ccode (obj_routine-obody obj) str))
    (format str "; /* initrout body end */~%")
    (let ( (nbsym (hash-table-count(compilation-symboldict this_compilation))) )
      (format str "/*intern ~d symbols*/~%" nbsym)
      (format *error-output* ";;writing init ~d interning ~g cpusec~%" nbsym (cpusec))
      )
    (let ( (symlist nil) ) 
      (maphash (lambda (sym data) (push sym symlist)) 
	       (compilation-symboldict this_compilation))
      (let ( (sortedsymlist (sort symlist (lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2))))) )
	(mapc (lambda (sym)
		(let ( (sydata (gethash sym (compilation-symboldict this_compilation))) )
					; (format_c_comment str "symbol ~S data ~S~%" sym sydata)
		  (format str "/*interning ~S*/~%" sym)
		  (if (keywordp sym)
		      (format str "(void) basilysgc_intern_keyword(")
		    (format str "(void) basilysgc_intern_symbol("))
		  (output_ccode sydata str)
		  (format str ");~%")
		  ))
	      sortedsymlist)))
    (format str " goto lab_endrout;~%")
    (format str " lab_endrout:~% debugeprintf(\"end init routine returning %p\", curfptr[0]);~%")
    (format str " basilys_topframe= (void*)(curfram__.prev); return curfptr[0];")
    (format str "}/* end start_module_basilys */~%")
    (setf (compilation-currout this_compilation) oldcurout)
    (finish-output str)
    ))

;;; compilation of nil
(defmethod compile_obj ((cod null) env)
  (make-obj_verbatim :vstr "/*Nil*/NULL")
)


;; compilation of symbols
(defmethod compile_obj ((cod symbol) env)
  (let ((bnd (cold_find_binding cod env)))
    (or bnd (error "compile_obj symbol: unbound symbol ~s in env ~s~% <::compile_obj unboundsym ~S in ~S>" 
		   cod env cod (obj_routine-syname (compilation-currout this_compilation))))
    (cond ( (cold_value_binding-p bnd)
	    (let ( (sdata (cold_value_binding-val bnd)) )
	      (cond
	       ( (eq (cold_value_binding-type bnd) :void)
		 (make-obj_verbatim :vstr (format nil "/*Void ~S*/NULL" cod)))
	       ( (obj_var-p sdata) sdata)
	       ( (currout_data2ptr sdata) )
	       ( t (newobjconst sdata "symb val"))
	       )))
	  ( (cold_class_binding-p bnd)
	    ;; a class is a constant, to be put in the routine's constant data
	    (let ( (cladata  (cold_class_binding-classdata bnd)) )
	      (assert (obj_data-p cladata) () "compilobj: bad data ~S for class ~S bnd ~S" cladata cod bnd)
	      (or (currout_data2ptr cladata) (newobjconst cladata "symb class"))
	      ))
	  ( (cold_field_binding-p bnd)
	    (let ( (fldata (cold_field_binding-fieldata bnd)) )
	      (assert (obj_data-p fldata) ()  "compilobj: bad data ~S for field ~S bnd ~S" fldata cod bnd)
	      (or (currout_data2ptr fldata) (newobjconst fldata "symb field"))
	      ))
	  ( (cold_instance_binding-p bnd)
	    (let ( (insdata (cold_instance_binding-instancedata bnd)) )
	      (assert (obj_data-p insdata) ()  "compilobj: bad data ~S for instance ~S bnd ~S" insdata cod bnd)
	      (or (currout_data2ptr insdata) (newobjconst insdata "symb inst"))
	      ))
	  ( (cold_selector_binding-p bnd)
	    (let ( (seldata (cold_selector_binding-selectordata bnd)) )
	      (assert (obj_data-p seldata) ()  "compilobj: bad data ~S for selector ~S bnd ~S" seldata cod bnd)
	      (or (currout_data2ptr seldata) (newobjconst seldata "symb sel"))
	      ))
	  ( (cold_function_binding-p bnd)
	    (let ( (fundata (cold_function_binding-fclodata bnd)) )
	      (assert (obj_data-p fundata) ()  "compilobj: bad data ~S for function ~S bnd ~S" fundata cod bnd)
	      (or (currout_data2ptr fundata) (newobjconst fundata "symb fun"))
	      ))
	  ( (cold_code_binding-p bnd) 
	    (compile_obj (cold_code_binding-code bnd) env) )
	  (t (error "unexpected compile_obj symbol ~s~%!! bnd ~s~%!!env ~s~% <::compile_obj unexpectedsym ~S {bnd ~S} in ~S>" 
		    cod bnd env cod (type-of bnd)
		    (obj_routine-syname (compilation-currout this_compilation)))))
    ))


;;; compilation of quoted symbols
(defmethod compile_obj ((cod prog_quotesym) env)
  (declare (ignore env))
  (let ( (qs (prog_quotesym-qsym cod)) )
    (cond ( (or (symbolp qs) (keywordp qs))
;	    (warn "compilobj-quotesym cod=~S~%" cod)
	    (let* ( (odatsym (get_obj_symbol qs "quotesym"))
		    (osymptr  (currout_data2ptr odatsym))
		    )
;	    (warn "compilobj-quotesym odatsym ~S osymptr ~S~%" odatsym osymptr)
	      (or osymptr (newobjconst odatsym "quotsym"))))
	  ( t (error "compile_obj bad prog_quotesym ~S" cod) )
    )
))

;; compilation of closed variable occurrences
(defmethod compile_obj ((cod prog_closedvar) env)
  (let ( (cfun (prog_closedvar-clv_fun cod))
	 (cvar (prog_closedvar-clv_var cod)) )
    (let* ( (clovarseq 
	     (cond
	      ( (prog_defun-p cfun) (prog_defun-fun_closvars cfun) )
	      ( (prog_lambda-p cfun) (prog_lambda-lambda_closvars cfun) )
	      ( t (cerror "compile_obj prog_closedvar bad cfun ~s for cod ~s" cfun cod))))
	    (coff 
	     (progn
	       (position cvar clovarseq
		:test (lambda (c1 cv2) 
			(eq (if (symbolp c1) c1 (prog_closedvar-clv_var c1))
			    (prog_closedvar-clv_var cv2)))))
	     )
	    )
      (or coff (error "compile_obj prog_closedvar no offset for cod ~s ~%... in clovarseq ~S~%" 
		      cod))
      (make-obj_closedvar :cvar cvar :cfun cfun :coffset coff)
      )))


;; handling of closed variables in functions' closed variables and constants
(defun handleclosvar (pcv env)
  (if (and (prog_closedvar-p pcv)
	   (prog_defun-p (prog_closedvar-clv_fun pcv)))
      (let (
	    (cva (prog_closedvar-clv_var pcv))
	    )
	(or (symbolp cva) (error "bad cva in handleclosvar pcv ~S" pcv))
	(let ( (vbi (cold_find_binding cva env)) )
	  (cond ( (cold_value_binding-p vbi)
		 (cold_value_binding-val vbi) )
		( (cold_class_binding-p vbi)
		 (cold_class_binding-classdata vbi) )
		( (cold_field_binding-p vbi)
		 (cold_field_binding-fieldata vbi) )
		( (cold_instance_binding-p vbi)
		 (cold_instance_binding-instancedata vbi) )
		( (cold_selector_binding-p vbi)
		 (cold_selector_binding-selectordata vbi) )
		( (cold_function_binding-p vbi)
		 (cold_function_binding-fclodata vbi) )
		( t 
		 (error "handleclosdata unexpected binding vbi=~S cva=~S" 
			vbi cva))
		)
	  ))
      (progn
	pcv)
      )
  )

;;;; compilation of progns
(defmethod compile_obj ((cod prog_progn) env)
  (let ( (pbody (prog_progn-progn_body cod)) )
    (make-obj_block :instrs
		    (mapcar (lambda (comp) (compile_obj comp env)) pbody))
))


;;;; compilation of forevers

(defmethod compile_obj ((cod prog_forever) env)
  (let* ( (lbind (prog_forever-forever_bind cod))
	  (lbody (prog_forever-forever_body cod)) 
	  (lbnam (cold_any_binding-bname lbind))
	  (luniq (cold_forever_binding-uniq lbind))
	  (ltype (cold_forever_binding-type lbind))
	  (epilo nil)
	  (obody nil)
	  (lvar nil)
	  (nbind (make-cold_obforever_binding 
		  :bname lbnam
		  :type ltype
		  :uniq luniq
		  :lobvar nil))
	  (newenv (cold_fresh_env env))
	  )
    (cold_put_binding nbind newenv)
    (case ltype
	  ( :value 
	    (let ( (vvar 
		    (newobjptrvar (compilation-currout this_compilation) lbind
			       "forever value")) )
	      (setf (cold_obforever_binding-lobvar nbind) vvar)
	      (setq epilo (make-obj_clearptr :clrptrvar vvar))
	      (setq lvar vvar)
	      ))
	  ( :long 
	    (let ( (vvar 
		    (newobjlongvar (compilation-currout this_compilation) lbind
			       "forever num"
			       )) )
	      (setf (cold_obforever_binding-lobvar nbind) vvar)
	      (setq epilo (make-obj_clearlong :clrlongvar vvar))
	      (setq lvar vvar)
	      ))
	  (otherwise (error "bad forever ltype ~S in ~S" ltype cod))
	  )
    (setq obody (mapcar (lambda (i) (compile_obj i newenv)) lbody))
    (if lvar (case ltype
	       (:value (freeobjptrvar lvar))
	       (:long (freeobjlongvar lvar))
	       ))
    (make-obj_forever 
     :obforever_bind nbind
     :obforever_res (cold_obforever_binding-lobvar nbind)
     :obforever_dest nil
     :obforever_body obody
     :obforever_epilogue epilo
     )
    ))


;;;;
(defmethod compile_obj ((cod prog_exit) env)
  (let* ( (ebind (prog_exit-exit_bind cod))
	  (ebody (prog_exit-exit_body cod))
	  (lvar (cold_any_binding-bname ebind))
	  (nbind (cold_find_binding lvar env))
	  (nbody (mapcar (lambda (i) (compile_obj i env)) ebody))
	  (lasti (last nbody))
	  )
    (or (cold_obforever_binding-p nbind) 
	(error "bad binding in compile_obj prog_exit ~S" cod))
    (if (consp lasti) 
	(let* ( (nobv (cold_obforever_binding-lobvar nbind))
		(li (first lasti)) 
		(nli (put_destination li nobv)) )
	  (if nli 
	      (setf (car lasti) 
		    nli))))
    (make-obj_exit
     :obxit_bind nbind
     :obxit_body nbody)
    ))

;;;; compilation of multicall, using the obj_call
(defmethod compile_obj ((cod prog_multicall) env)
  (let ( (pformalist (prog_multicall-multicall_formals cod)) 
	 (pcall (prog_multicall-multicall_call cod))
	 (pbody (prog_multicall-multicall_body cod)) 
	 (newenv (cold_fresh_env env))
	 (revinstrseq nil)
	 (revresultvars nil)
	 ) 
    (assert (or (prog_apply-p pcall) (prog_send-p pcall)))
    (flet ( 
	   (handleformalbind 
	    (bnd)
	    (let ( (bname (cold_any_binding-bname bnd))
		   (btype (cold_typed_binding-type bnd))
		   )
	      (case btype
		    (:value 
		     (let ( (vvar 
			     (newobjptrvar (compilation-currout this_compilation) bnd 
					   "multicall value"
					   )) )
		       (cold_put_binding 
			(make-cold_value_binding :bname bname :val vvar :type btype) 
			newenv)
		       (push (build_obj_compute vvar (list "(void*)0") btype) 
			     revinstrseq)
		       (push vvar revresultvars)
		       ))
		    (:long
		     (let ( (nvar 
			     (newobjlongvar (compilation-currout this_compilation) bnd 
					    "multicall long"
					 )) )
		       (cold_put_binding
			(make-cold_value_binding :bname bname :val nvar :type btype)
			newenv)
		       (push (build_obj_compute nvar (list "0L") btype) 
			     revinstrseq)
		       (push nvar revresultvars)
		       ))
		    (otherwise (error "compile_obj prog_multicall unexpected bnd ~S"
				      bnd))))
	    ))
	  (mapc (function handleformalbind) pformalist)
	  )
    (let* ( (resultvars (reverse revresultvars)) 
	    )
      (cond
       ( (prog_apply-p pcall)
	 (push (make-obj_call 
		:dest (first resultvars)
		:clos (compile_obj (prog_apply-appl_fun pcall) env)
		:xtraresults (rest resultvars)
		:args (mapcar (lambda (e) (compile_obj e env))
			      (prog_apply-appl_args pcall))
		) revinstrseq))
       ( (prog_send-p pcall)
	 (push (make-obj_send
		:obs_dest (first resultvars)
		:obs_sel (compile_obj (prog_send-send_sel pcall) env)
		:obs_recv (compile_obj (prog_send-send_recv pcall) env)
		:obs_args   (mapcar (lambda (e) (compile_obj e env))
				    (prog_send-send_args pcall))
		:obs_xtraresults (rest resultvars)
		) revinstrseq))
       ( t
	 (error "unexpected call ~S in multicall" pcall))
       )
      )
    (mapc (lambda (e) (push (compile_obj e newenv) revinstrseq)) pbody)
    (make-obj_block
     :instrs (reverse revinstrseq))
    ))

;;;;;;;;;;;;;;;;;;; compilation of toplev definitions

(defmethod compile_obj ((cod prog_defun) env)
  (push cod (compilation-functions this_compilation))
  ;; (format *error-output* "compile_obj prog_defun cod <ici> ~S~%" cod)
  (let* (
	 ;; if the defun originated from a lambda, we do not need to
	 ;; build a dataclosure
	 (slambda (prog_defun-fun_lambda cod))
	 (orout (make-obj_routine 
		 :pfun cod 
		 :nbptr 1 		;reserve slot for result ptr
		 :nbnum 0 
		 :nbdouble 0 
		 :nbcstring 0
		 :obody nil
		 :syname  (prog_def-def_name cod)
		 :rank (length  (compilation-functions this_compilation))
		 :data2ptrhash (make-hash-table :size 31)
		 )) 
	 (odatarout (add_cdata (make-obj_dataroutine
				:comname (prog_def-def_name cod)
				:discr 'DISCR_ROUTINE
				:rout orout
				)
			       "defun datarout"
			       ))
	 (funbind (and 
		   (null slambda)
		   (cold_find_binding  (prog_def-def_name cod) env)
		   ))
	 (odatacl (and 
		   (null slambda)
		   (cold_function_binding-p funbind)
		   (let ( (ofunclo (cold_function_binding-fclodata funbind)) )
		     (assert (obj_dataclosure-p ofunclo))
		     (setf (obj_dataclosure-rout ofunclo) orout)
		     (setf (obj_dataclosure-discr ofunclo) 'DISCR_CLOSURE)
		     (add_cdata ofunclo "defun dataclo")
		     )))
	 (oarginsrev nil)
	 (fbind (prog_defun-fun_argbindings cod)) 
	 (newenv (cold_fresh_env env))
	 (oldcurrout (compilation-currout this_compilation))
	 )
    (setf (obj_routine-dataclos orout) odatacl)
    (setf (obj_routine-datarout orout) odatarout)
    (setf (compilation-currout this_compilation) orout)
    ;; bind the name to the dataclosure if available
    (if odatacl 
	(cold_put_binding 
	 (make-cold_value_binding  :bname  (prog_def-def_name cod) 
				   :val odatacl :type ':value)
	 env))
    (cold_delay
     (format nil "compilobj defun ~S closvar"  (prog_def-def_name cod))
     (if odatacl 
	 (setf (obj_dataclosure-clodata odatacl)
	       (mapcar (lambda (var) (handleclosvar var env)) 
		       (prog_defun-fun_closvars cod))))
     (mapcar (lambda (var) 
	       (push 
		(handleclosvar var env)
		(obj_dataroutine-roudata odatarout)
		)) 
	     (prog_defun-fun_constants cod)))
    (labels
     ( (bindvar (nam val type) 
		(let ( (nbi (make-cold_value_binding 
			     :bname nam :val val :type type))) 
		  (cold_put_binding nbi newenv
				    )))
       ( doptr (b) 			;add a value arg
	       (let ( (ovar (newobjptrvar orout b
					  "defun doptr"
					  )) )
		 (bindvar (cold_formal_binding-bname b) ovar ':value)
		 (push (make-obj_getptrarg_instr
			:dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
		 ) )
       ( dolong (b) 			;add a numerical arg
		(let ( (ovar (newobjlongvar orout b  
					    "defun dolong"
					 )) )
		  (bindvar (cold_formal_binding-bname b) ovar ':long)
		  (push (make-obj_getlongarg_instr 
			 :dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
		  ) )
       ( do_cstring (b) 			;add a constant cstring arg
		(let ( (ovar (newobjcstringvar orout b  
					    "defun do_cstring"
					 )) )
		  (bindvar (cold_formal_binding-bname b) ovar ':cstring)
		  (push (make-obj_getcstringarg_instr 
			 :dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
		  ) )
       ( doit (b)			;handle by dispatching
	      (case (cold_formal_binding-type b)
		    (:value (doptr b))
		    (:long (dolong b))
		    (:cstring (do_cstring b))
		    (otherwise (error "compile_obj progdefun unexpected binding ~s" b)))
	      )
       (comp1 (i)			;compile 1 instruction
	      (compile_obj i newenv)
	      )
       (comp (i)			;compile 1 or many instr
	     (if (listp i) (mapcar #'comp1 i) (comp1 i))
	     )
       )
     (mapcar (function doit) fbind)
     (let* ( (funbody (prog_defun-fun_body cod)) ;compile the entire body
	     (objbody (comp funbody)) 
	     (insarg (make-obj_get_arguments :instrs (reverse oarginsrev))) )
;;; put the proper list of instructions
       (setf (obj_routine-obody orout)
	     (if (listp objbody) (cons insarg objbody) (list insarg objbody)))
;;; restore compilation & return the routine
       (setf (compilation-currout this_compilation) oldcurrout)
       orout
       ))))


;;;; compilation of a primitive
(defmethod compile_obj ((cod prog_defprimitive) env)
  ;; create an object with 3 fields: the name, the formal tuple, the expansion tuple
  (let* 
      (
       (pname (prog_def-def_name cod))
       (pformals (prog_defprimitive-primitive_formals cod))
       (ptype (prog_defprimitive-primitive_type cod))
       (pexpand (prog_defprimitive-primitive_expansion cod))
       (onamestr (add_cdata (make-obj_datastring
			     :comname pname
			     :discr 'DISCR_STRING 
			     :string (string pname))
			    "defprimit namstr"
			    ))
       (oformals 
	(mapcar 
	 (lambda (forbi)
	   (add_cdata (make-obj_datainstance
		       :comname pname
		       :discr 'CLASS_FORMAL_BINDING
		       :slots (list 
			       (get_obj_symbol (cold_formal_binding-bname forbi) "defprimi forbi")
			       (get_obj_type (cold_formal_binding-type forbi)))
		       )
		      "defprimit formal"
		      ))
	 pformals))
       (oexptuple 
	(add_cdata 
	 (make-obj_datamultiple
	  :comname pname
	  :discr 'DISCR_MULTIPLE
	  :values 
	  (mapcar 
	   (lambda (e)
	     (cond 
	      ((symbolp e)
		    (let ((po (position-if
			       (lambda (bi) (eq (cold_formal_binding-bname bi) e))
			       pformals)))
		      (or po 
			  (error "unexpected symbol ~S in defprimitive ~S" e cod))
		      (nth po oformals)
		      )
		    )
	      ((stringp e)
	       (add_cdata (make-obj_datastring
			   :comname pname
			   :discr 'DISCR_STRING 
			   :string e)
			  "defprimit string"
			  ))
	      (t (error "unexpected stuff ~S in defprimitive ~S" e cod))
	      ))
	     pexpand))
	 "defprimit exptuple"
	 ))
       (oformaltuple
	(add_cdata
	 (make-obj_datamultiple
	  :comname (prog_def-def_name cod)
	  :discr 'DISCR_MULTIPLE
	  :values oformals)
	 "defprimit formtuple"
	 ))
       (oprim (add_cdata (make-obj_datainstance 
			  :comname pname
			  :discr 'CLASS_PRIMITIVE
			  :slots (list nil onamestr oformaltuple oexptuple))
			 "defprimit oprim"
			 )
	      )
       )
    nil
    ))




;; recursive ancestors in reversed order
(defun revancestors_defclass (dc)
  (if dc 
      (let 
	  ((supdc (prog_defclass-class_super dc)))
	(if supdc (cons supdc (revancestors_defclass supdc))))))

;; recursive fields in reversed order
(defun revfields_defclass (dc)
  (if dc 
      (let ((supdc (prog_defclass-class_super dc)))
	(revappend (prog_defclass-class_ownfields dc) (revfields_defclass supdc)))))


;;;;; compilation of a defclass
(defmethod compile_obj ((cod prog_defclass) env)
  (let (
	(pname (prog_def-def_name cod))
	(ppredef (prog_predef-predef_rank cod))
	(allfields (reverse (revfields_defclass cod)))
	(allancestors (reverse (revancestors_defclass cod)))
	)
    (let* (
	   (obstrname (add_cdata 
		       (make-obj_datastring
			:comname pname
			:discr 'DISCR_STRING :string (string pname))
		       "defclass strname"
		       )) 
	   (obclass (add_cdata 
		     (make-obj_datainstance 
		      :comname pname
		      :discr 'CLASS_CLASS
		      :predef ppredef
		      :objnum 'OBMAG_OBJECT)
		     "defclass obclass"
		     ))
	   (clabind (cold_find_binding (prog_defclass-def_name cod) env))
	   (obancestorstuple 
	    (add_cdata 
	     (make-obj_datamultiple
	      :comname (prog_def-def_name cod)
	      :discr 'DISCR_SEQCLASS
	      :values 
	      (mapcar
	       (lambda (anc) 
		 (assert (prog_defclass-p anc))
		 (let* ( (ancbind (cold_find_binding 
				   (prog_defclass-def_name anc) env))
			 (ancdata (cold_class_binding-classdata ancbind))
			 )
		   ancdata
		   ))
	       allancestors)
	      )
	     "defclass seqancestors"
	     ))
	   (obsuper 
	    (if allancestors
		(let* (
		       (anc (first (last allancestors)))
		       (ancbind (cold_find_binding 
				 (prog_defclass-def_name anc) env))
		       (ancdata (cold_class_binding-classdata ancbind))
		       )
		  ancdata
		  )))
	   (obfieldstuple 
	    (add_cdata 
	     (make-obj_datamultiple
	      :comname (prog_def-def_name cod)
	      :discr 'DISCR_SEQFIELD
	      :values  
	      (mapcar
	       (lambda (f) 
		 (assert (prog_field-p f))
		 (let ( (fldata
			 (add_cdata 
			  (make-obj_datainstance 
			   :comname (prog_field-def_name f)
			   :discr 'CLASS_FIELD
			   :objnum (prog_field-field_offset f)
			   :slots
			   (list nil 
				 (add_cdata 
				  (make-obj_datastring
				   :comname (prog_def-def_name f)
				   :discr 'DISCR_STRING
				   :string (string (prog_def-def_name f))))
				 nil))))
			(flbind
			 (cold_find_binding (prog_field-def_name f) env))
			)
		   (assert (cold_field_binding-p flbind))
		   (setf (cold_field_binding-fieldata flbind) fldata)
		   )
		 )
	       allfields)
	      )
	     "defclass fieldtupl"
	     ))
	   )
      (setf (cold_class_binding-classdata clabind) obclass)
      (setf (obj_datainstance-slots obclass) 
	    (list 
	     nil			;no prop
	     obstrname
	     nil			;no methodict
	     nil 			;no sendclosure
	     obsuper			;disc_super
	     obancestorstuple
	     obfieldstuple
	     nil			;no objnumdescr
	     nil			;nod classdata
	     ))
      nil				;result of compile_obj
      )))


;;; compile a definstance (not a defselector!)
(defmethod compile_obj ((cod prog_definstance) env)
  (let ( (iname (prog_def-def_name cod))
	 (ipredef (prog_predef-predef_rank cod))
	 (iclass (prog_definstance-inst_class cod))
	 (iobjnum (prog_definstance-inst_objnum cod))
	 (islots (prog_definstance-inst_slots cod)) )
    (assert (prog_defclass-p iclass))
    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
	   (insbind (cold_find_binding iname env))
	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
	   )
      (assert (cold_instance_binding-p insbind))
      (assert (cold_class_binding-p clabind))
      (assert (cold_class_binding-classdata clabind))
      (let ( (ob
	      (make-obj_datainstance 
	       :comname (prog_def-def_name cod)
	       :discr (cold_class_binding-classdata clabind)
	       :objnum 
	       ;;special hack for OBMAG_* names or others
	       (if (symbolp iobjnum) iobjnum
		 (compile_obj iobjnum env))
	       :predef ipredef))
	     ) 
	(add_cdata ob "definstance ob")
	(setf (cold_instance_binding-instancedata insbind) ob)
	;; fill the slot, should be here to allow
	;; a slot to refer to the newly made
	;; instance
	(mapc (lambda (s)
		(setf (aref slovec 
			    (prog_field-field_offset (instance_slot-slot_field s)) )
		      (let* ( (cobs 
			       (compile_obj (instance_slot-slot_value s) env)) 
			      ;; we put the tempslot variable as destination
			      (pobs
			       (put_destination cobs cold_tempslot_var))
			      )
			(or pobs cobs)
			)))
	      islots)
	(setf (obj_datainstance-slots ob)
	      (concatenate 'list slovec)) ;; convert slovec to a list
	ob
	)
      )
    nil))

;;; compile a defselector is quite similar to a definstance
(defmethod compile_obj ((cod prog_defselector) env)
  (let ( (iname (prog_def-def_name cod))
	 (ipredef (prog_predef-predef_rank cod))
	 (iclass (prog_definstance-inst_class cod))
	 (iobjnum (prog_definstance-inst_objnum cod))
	 (islots (prog_definstance-inst_slots cod)) )
    (assert (prog_defclass-p iclass))
    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
	   (insbind (cold_find_binding iname env))
	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
	   )
      (assert (cold_selector_binding-p insbind))
      (assert (cold_class_binding-p clabind))
      (assert (cold_class_binding-classdata clabind))
      (let* ( 
	     (onamestr (add_cdata (make-obj_datastring
				   :comname iname
				   :discr 'DISCR_STRING 
				   :string (string iname))
				  "defselect namstr"
				  ))
	     (ob
	      (make-obj_datainstance 
	       :comname (prog_def-def_name cod)
	       :discr (cold_class_binding-classdata clabind)
	       :objnum 
	       ;;special hack for OBMAG_* names or others
	       (if (symbolp iobjnum) iobjnum
		 (compile_obj iobjnum env))
	       :predef ipredef))
	     ) 
	(add_cdata ob "defselector ob")
	(setf (cold_selector_binding-selectordata insbind) ob)
	;; fill the slot, should be here to allow
	;; a slot to refer to the newly made
	;; instance
	(mapc (lambda (s)
		(setf (aref slovec 
			    (prog_field-field_offset (instance_slot-slot_field s)) )
		      (let* ( (cobs 
			       (compile_obj (instance_slot-slot_value s) env)) 
			      ;; we put the tempslot variable as destination
			      (pobs
			       (put_destination cobs cold_tempslot_var))
			      )
			(or pobs cobs)
			)))
	      islots)
	;; put into the 2nd = rank1 (for :named_name field) position the onamestr
	(setf (aref slovec 1) onamestr)
	(setf (obj_datainstance-slots ob)
	      (concatenate 'list slovec)) ;; convert slovec to a list
	ob
	)
      )
    nil))




;; get (and generate if needed) the objinstance for a symbol
(defun get_obj_symbol (sym &optional why) 
  (assert (symbolp sym) (sym) "bad argument to get_obj_symbol ~S" sym)
  (let ((sydict (compilation-symboldict this_compilation)))
    (or (gethash sym sydict) 
	(let* ( 
	       (onamestr (add_cdata (make-obj_datastring
				     :comname sym
				     :discr 'DISCR_STRING 
				     :string (string sym))
				    (if why (concatenate 'string "GetObjSymb namstr " why)
				      "getobjsymb namstr")
				    ))
	       (osym (add_cdata (make-obj_datainstance
				 :discr (if (keywordp sym) 'CLASS_KEYWORD 'CLASS_SYMBOL)
				 :comname sym
				 :slots (list nil onamestr nil))
				(if why (concatenate 'string "GetObjSymb osym " why)
				  "getobsymb osym")
				))
	       )
	  (setf (gethash sym sydict) osym)
	  osym
	  )
	#|				;
	(let* ( (odatasym  (make-obj_dataqsymbol :comname sym :qsymb sym)) 
	(osym (or (currout_data2ptr odatasym) (newobjconst odatasym))) )
	(setf (gethash sym sydict) osym)
	osym
	)
	|#
)))

;; translate a type
(defun get_obj_type (ty)
  (case ty
	(:value 'CTYPE_VALUE)
	(:long 'CTYPE_LONG)
	(:cstring 'CTYPE_CSTRING)
	(t (error "bad type to get_obj_type ~S" ty))))



;;;;;;;;;;;;;;;;;;; compilation of instructions
(defmethod compile_obj ((cod prog_let) env)
  (let ( (lbind (prog_let-let_bindings cod))
	 (lbody (prog_let-let_body cod)) 
	 (newenv (cold_fresh_env env))
	 (locptrvars nil)		;list of local pointers vars (to be freed & cleared)
	 (loclongvars nil)		;list of local long vars (to be freed & cleared)
	 (revinstrseq nil)
	 )
    (labels 
	( (checkbinding 
	   (bnd)			; compute the type of each binding if it didn't have one
	   (assert (cold_let_binding-p bnd))
	   (if (null (cold_let_binding-type bnd))
	       (let ( (bexpr (cold_let_binding-expr bnd)) )
		 (cond ( (prog_primitive-p bexpr) 
			 (setf (cold_let_binding-type bnd) 
			       (prog_defprimitive-primitive_type
				(prog_primitive-prim_oper bexpr)))
			 )
		       ( (and (atom bexpr)
			      (cold_find_binding bexpr env))
			 (let ( (exbnd (cold_find_binding bexpr env)) )
			   (and 
			    (cold_typed_binding-p exbnd)
			    (cold_typed_binding-type exbnd)
			    (setf (cold_let_binding-type bnd) 
				  (cold_typed_binding-type exbnd))
			    )
			   )
			 ))))
	   ;; by default set the type to :value
	   (if (null (cold_let_binding-type bnd))
	       (setf (cold_let_binding-type bnd) ':value))
	   )
	  (handlebinding
	   (bnd)
	   (let ( (bexpr (cold_let_binding-expr bnd)) 
		  (btype (cold_typed_binding-type bnd)) 
		  (bname (cold_any_binding-bname bnd))
		  )
	     (case btype
	       (:value 
		(let ( (vvar 
			(newobjptrvar (compilation-currout this_compilation) bnd 
				      "compilet ptr" )) )
		  (push vvar locptrvars)
		  (cold_put_binding 
		   (make-cold_value_binding :bname bname :val vvar :type btype) 
		   newenv)
		  (let ( (compexp  
			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
		    (push (or (put_destination compexp vvar) compexp) revinstrseq)
		    )))
	       (:long 
		(let ( (nvar 
			(newobjlongvar (compilation-currout this_compilation) bnd 
				       "compilet long")) )
		  (push nvar loclongvars)
		  (cold_put_binding
		   (make-cold_value_binding :bname bname :val nvar :type btype)
		   newenv)
		  (let ( (compexp  
			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
		    (push (or (put_destination compexp nvar) compexp) revinstrseq)
		    )))
	       (:void
		;; dont use any objvar and dont putdest
		(cold_put_binding
		 (make-cold_value_binding :bname bname :val nil :type btype)
		 newenv)
		(let ( (compexp  
			(compile_obj  (cold_let_binding-expr bnd) newenv)) )
		  (push compexp revinstrseq)
		  ))
	       (otherwise (error "compile_obj prog_let unexpected binding ~s" bnd))
	       )
	     )
	   )
	  (comp1 
	   (cod)
	   (push (compile_obj cod newenv) revinstrseq)
	   )
	  (comp 
	   (cod)
	   (if (listp cod) (mapcar (function comp1) cod) (comp1 cod)))
	  )
      (mapc (function checkbinding) lbind)
      (mapc (function handlebinding) lbind)
      (comp lbody)
      (let ( (lbc (first revinstrseq)) );; lbc is the last body compiled ...
       ;;; generates clears only if the compiled body is a variable
       ;;; which we don't clear
	(mapcar (lambda (pv) 
		  (if (and (obj_var-p lbc) (not (eql lbc pv)))
		      (push (make-obj_clearptr :clrptrvar pv) revinstrseq))
		  (freeobjptrvar pv)
		  ) locptrvars)
	(mapcar (lambda (lv)
		  (if (and (obj_var-p lbc) (not (eql lbc lv)))
		      (push (make-obj_clearlong :clrlongvar lv) revinstrseq))
		  (freeobjlongvar lv)
		  ) loclongvars)
	;;; push again the lbc to make it the result of the block
	(if (obj_var-p lbc)
	    (push lbc revinstrseq))))
    (make-obj_block :instrs (reverse revinstrseq))
    )
  )

(defmethod compile_obj ((cod prog_primitive) env)
  (error "unexpected call to compile_obj prog_primitive cod ~S env ~S" cod env)
  )

(defmethod compile_obj ((cod prog_chunk) env)
  (let* ( (chargs (prog_chunk-chunk_args cod)) 
	  (objc (build_obj_compute 
		 nil
		 (mapcar (lambda (a)
			   (cond ((stringp a) (make-obj_verbatim :vstr a))
				 ((numberp a) a)
				 (t (compile_obj a env)))
			   )
			 chargs)
		 (prog_chunk-chunk_type cod)
		 )) )
    objc
    ))


(defmethod compile_obj ((cod prog_unsafe_get_field) env)
  (let* ( (ugfield (prog_unsafe_get_field-uget_field cod))
	  (ugobj (prog_unsafe_get_field-uget_obj cod)) )
    (assert (prog_field-p ugfield))
    (build_obj_compute
     nil
     (list "/*unsafe_get*/ (basilys_field_object(("
	   (compile_obj ugobj env)
	   "), ("
	   (prog_field-field_offset ugfield)
	   "))"
	   (format nil "/**.~a.**/" (prog_field-def_name ugfield))
	   ")"
	   )
     :value
     )))


(defmethod  compile_obj ((cod prog_unsafe_put_fields) env)
  (let* ( (upobj (prog_unsafe_put_fields-uput_obj cod))
	  (upkeys (prog_unsafe_put_fields-uput_keys cod))
	  (revinstrs nil) )
    ;; push the destination in a register
    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register basilysobject_ptr_t obdest= 0;")
	  revinstrs)
    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register int oblen= 0;")
	  revinstrs)
    (push 
     (build_obj_compute
      nil
      (list "/*unsafe_put setdest*/ obdest = (void*)"
	    (compile_obj upobj env))
      :value
      )
     revinstrs)
    (push (make-obj_verbatiminstr :vstr "gcc_assert(basilys_magic_discr(obdest) == OBMAG_OBJECT);")
	  revinstrs)
    (push (make-obj_verbatiminstr :vstr "oblen = basilys_object_length(obdest);")
	  revinstrs)
    (let ( (maxfldoff 0) )
      (loop
       for curkpair in upkeys do
       (let ( (curfld (car curkpair))
	      (curexp (cdr curkpair))
	      )
	 (assert (prog_field-p curfld))
	 (setq maxfldoff (max maxfldoff (prog_field-field_offset curfld)))
       ))
    (push (make-obj_verbatiminstr :vstr (format nil "gcc_assert(oblen > ~d);" maxfldoff))
	  revinstrs)
      )
    ;; push the field initializations
    (mapc 
     (lambda (curkpair)
       (let ( (curfld (car curkpair))
	      (curexp (cdr curkpair))
	      )
	 (assert (prog_field-p curfld))
	 (push
	  (build_obj_compute
	   nil
	   (list
	    "/*unsafe_put field*/ basilys_checked_assign(obdest->obj_vartab["
	    (prog_field-field_offset curfld)
	    "] "
	    (format nil "/**.~a.**/" (prog_field-def_name curfld))
	    " = (basilys_ptr_t)(" 
	    (compile_obj curexp env)
	    "))"
	    )
	   :value
	   )
	  revinstrs)
	 ))
     upkeys)
    ;; push the touch of the destination
    (push
     (build_obj_compute 
      nil
      (list "/*unsafe_put touch*/ basilysgc_touch(obdest)")
      :void
      )
     revinstrs)
    ;; push the destination itself as the result
    (push
     (compile_obj upobj env)
     revinstrs)
    ;; return the block
    (make-obj_block :instrs (reverse revinstrs))
    ))


(defmethod compile_obj ((cod prog_make_instance) env)
  (let ( (classv (prog_make_instance-mki_class cod)) 
	 (mikeys (prog_make_instance-mki_keys cod)) 
	 (classd (prog_make_instance-mki_classdef cod))
	 (revinstrs nil)
	 )
    ;; push the destination in a register
    (push (make-obj_verbatiminstr :vstr "/*makeinst*/register basilysobject_ptr_t obnew= 0;")
	  revinstrs)
    (let ( (compclass (compile_obj classv env)) 
	   (siznew  (length (prog_defclass-class_allfields classd)))
	   )
      (if (and (compilation-currout this_compilation)
	       (obj_data-p compclass))
	  (setq compclass (newobjconst compclass "makeinst class")))
					;      (warn "compile_obj make_instance cod ~S compclass ~S env ~S ~%...compilobj make_inst currout ~S" 
					;	     cod compclass env (compilation-currout this_compilation))
      (push 
       (build_obj_compute
	nil
	(list "/*make_instance*/obnew = basilysgc_new_raw_object( (void*)"
	      compclass
	      "," 
	      siznew
	      ")")
	:value
	)
       revinstrs)
      ;; push the field initializations
      (mapc 
       (lambda (curkpair)
	 (let ( (curfld (car curkpair))
		(curexp (cdr curkpair))
		)
	   (assert (prog_field-p curfld))
	   (assert (< (prog_field-field_offset curfld) siznew))
	   (push
	    (build_obj_compute
	     nil
	     (list
	      "/*make_inst field*/ basilys_checked_assign(obnew->obj_vartab["
	      (prog_field-field_offset curfld)
	      "] "
	      (format nil "/**.~a.**/" (prog_field-def_name curfld))
	      " = (basilys_ptr_t)(" 
	      (compile_obj curexp env)
	      "))"
	      )
	     :value
	     )
	    revinstrs)
	   ))
       mikeys)
      )
    ;; push the new object itself as the result
    (push
     (make-obj_verbatim :vstr "obnew")
     revinstrs)
    ;; return the block
    (make-obj_block :instrs (reverse revinstrs))
    ))


(defun compile_argobj (cod env)
;;@@@@ STRING ARGUMENTS ARE HANDLED HERE
;;- (if (stringp cod) 
;;-     (let*  ( (obstrdata 
;;-		(add_cdata (make-obj_datastring
;;-			    :comname cod
;;-			    :discr 'DISCR_STRING
;;-			    :string cod)
;;-			   "argobj strdata")
;;-		) 
;;-	       (constri (newobjconst obstrdata "argobj constri")) 
;;-	       )
;;-	;;; (warn "compile_argobj cod ~S obstrdata ~S constr ~S env ~S~%" cod obstrdata constri env)
;;-	constri) 
   (compile_obj cod env)
  )
;;- )


(defmethod compile_obj ((cod prog_apply) env)
  (let ( (apfun (prog_apply-appl_fun cod))
	 (apargs (prog_apply-appl_args cod)) )
    (make-obj_call
     :clos (compile_obj apfun env)
     :args (mapcar (lambda (c) (compile_argobj c env)) apargs)
     )
    )
)

(defmethod compile_obj ((cod prog_send) env)
  (let ( (isel (prog_send-send_sel cod))
	 (irecv (prog_send-send_recv cod))
	 (iargs (prog_send-send_args cod)) )
    (make-obj_send
     :obs_dest nil
     :obs_sel (compile_obj isel env)
     :obs_xtraresults nil
     :obs_recv (compile_obj irecv env)
     :obs_args  (mapcar (lambda (c) (compile_argobj c env)) iargs)
     )
))




(defmethod compile_obj ((cod prog_lambda) env)
  (error "should never be called compile_obj prog_lambda cod=~S ~%" cod)
)


(defmethod compile_obj ((cod prog_makeclosure) env)
  (flet 
      ( (comp (c) (compile_obj c env)) )
    (let* 
	( (cfun (prog_makeclosure-mkclos_fun cod)) 
	  (cvars (prog_makeclosure-mkclos_closvars cod))
	  (mkc
	   (make-obj_mkclosure 
	    :cfun cfun
	    :cvals (mapcar (function comp) cvars)
	    ) 
	   )
	  )
      (let ((obr 
	     (find-if 
	      (lambda (o) 
		(and (obj_dataroutine-p o)
		     (eq (obj_routine-pfun (obj_dataroutine-rout o)) cfun)))
	      (compilation-cdata this_compilation))))
	(or obr (error "compile_obj makeclosure ~S ~%..cannot find dataroutine for ~S"
		       cod cfun))
	(setf (obj_mkclosure-kobjrout mkc) (newobjconst obr "makeclos objro"))
	mkc
	))))



(defmethod compile_obj ((cod prog_return) env)
  (let ( (progrets (prog_return-retexprs cod)) )
    (or (listp progrets) (error "bad prog_return without list return ~s" cod))
    (let ( (compexprs (mapcar (lambda (c) (compile_obj c env)) progrets)) )
      (let ( (retmain (and (consp compexprs) (first compexprs))) 
	     (retextras (and (consp compexprs)  (rest compexprs))) )
	(and (prog_src-p retmain) (not (eq (query_ctype retmain) :value))
	     (error "prog_return has bad main value ~s" cod))
	(if retmain
	    (progn
;	      (warn "compilobjreturn retmain ~S retextras ~S~%" retmain retextras)
	      (let ( (newretmain (put_destination retmain cold_return_var)) )
	      (if newretmain (setq retmain newretmain)))))
	(make-obj_return
	 :mainreturn retmain
	 :extrareturns retextras)
   )
)))


(defmethod compile_obj ((cod prog_setq) env)
  (let* ( (pva (prog_setq-setq_var cod))
	  (pex (prog_setq-setq_expr cod)) 
	  (cva (compile_obj pva env))
	  (cex (compile_obj pex env))
	  (typcva (query_ctype cva))
	  (typcex (query_ctype cex))
	  )
    (and typcva typcex 
	 (or (eq typcva typcex)
	     (error "setq incompatible type cod ~S~%.. cva ~S~%.. cex ~S~%" cod cva cex)))
    (if (consp cex) (error "setq multi-expr cod ~S cex ~S" cod cex))
    (if (obj_var-p cva)
	(build_obj_compute
	 cva
	 (if (listp cex) cex (list cex))
	 typcex
	 )
      (make-obj_closetq
       :cldest cva
       :val cex)
      )))


(defmethod compile_obj ((cod prog_if) env)
  (let ( (pcond (prog_if-cond_expr cod))
	 (pthen (prog_if-then_expr cod)) 
	 (pelse (prog_if-else_expr cod)) )
    (let ( (ocond (compile_obj pcond env))
	   (othen (and pthen (compile_obj pthen env)))
	   (oelse (and pelse (compile_obj pelse env))) )
      (if (and othen oelse) 
	  (let ( (thenctype (if othen (or (query_ctype othen) :value)))
		 (elsectype (if oelse (or (query_ctype oelse) :value))) )
	    (or 
	     (eq thenctype elsectype)
	     (eq thenctype ':void)
	     (eq elsectype ':void)
	     (warn "if incompatible type cod ~S~%.. othen ~S~%... thenctype ~S ~%.. oelse ~S~%... elsectype ~S~%"
		   cod othen  thenctype oelse elsectype))))
      (make-obj_if
       :ob_cond ocond
       :ob_then othen
       :ob_else oelse
       )
      )))




;;;;;;;;;;;;; parsing a source file
(defun ctime ()
  (multiple-value-bind
   (second minute hour date month year day-of-week dst-p tz)
   (get-decoded-time)
   (format nil "~4,'0d ~a ~2,'0d @ ~2,'0d:~2,'0d:~2,'0d (GMT~@d)"
	   year (nth month '("???" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
			     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
	   date hour minute second tz))
)


(defun compile_toplev (cod freshenv)
  ;; if it is a definition, compile it
  (if (prog_def-p cod)
      (progn
;	(format *error-output* "compile_toplev def cod=~S" cod)
	(let ( (ce (compile_obj cod freshenv)) )
;	  (format  *error-output* "compile_toplev def ce=~S" cod)
	  (if ce (add_objcode ce))
	  )
	)
    ;; not a definition, compile it appropriately and add it to the
    ;; initial routine's body
    (let* ( 
	   (oldcurrout (compilation-currout this_compilation))
	   (initrout (compilation-initrout this_compilation))
	   (initbody (obj_routine-obody initrout))
	   )
      (setf (compilation-currout this_compilation) initrout)
;      (format *error-output* "compile_toplev avant compile_obj cod=~S~%" cod)
      (let ( (ce (compile_obj cod freshenv)) )
;	(format *error-output* "compile_toplev apres compile_obj cod=~S ce=~S~%" cod ce)
	(if ce (setf (obj_routine-obody initrout)
		     (append initbody (list ce))))
	)
      (setf (compilation-currout this_compilation) oldcurrout)
      )))


;; limit the CPU time to 1000 sec on Clisp
;; sometimes a clisp.run process remains.... eg when killing xemacs...
#+CLISP
(setf (posix:rlimit :cpu) (values 1000 1200))


;; first argument is mandatory MELT/basilys source, second argument
;; may be the generated C file
(defun handle-source-file (filename &optional outnamearg)
  (with-open-file
   (istr filename)
   (format *error-output* "reading file ~s ~%" filename)
   (let ( (*readtable* (copy-readtable)) 
	  (readrevseq nil)
	  (outpathname (if (stringp outnamearg) outnamearg 
			 (make-pathname :name (pathname-name filename) :type "c")))
	  )
     (loop 
      (let ((rditem (read istr nil)))
	(if (null rditem)
	    (return)
	  (push rditem readrevseq) 
	  )
	)
      )
     (let* ( (readseq (reverse readrevseq)) 
	     (initrout (make-obj_initroutine 
			:nbptr 3
			:nbnum 1
			:nbdouble 0
			:pfun 'init	
			:data2ptrhash (make-hash-table :size 281)
			:inirou_datarankdict  (make-hash-table :size 281)
			)) 
	     (thiscompil (make-compilation 
			  :symboldict (make-hash-table)
			  :initrout initrout
			  )) 
	     ) 
       (setq this_compilation thiscompil)
       (with-open-file
	(outstr outpathname :direction :output :if-exists :rename)
	(format outstr "/* generated file ~a on ~a */~%#include \"run-basilys.h\"~%" outpathname (ctime))
	(format outstr "#define COLD_EXTRAGAP 2 /*the cold generator is buggy so need the gap */~%")
	(format outstr "/*** read ~d inputs ***/ ~%~%" (length readseq)) 
	(loop
	 for rk from 1
	 for curinp in readseq
	 do 
	 (format_c_comment outstr "++ input #~d~%~S~% ++~%~%" rk curinp))
;	(finish-output outstr)
	(format *error-output* "read ~d items from file ~s ~%" 
		(length readseq) filename)
	(let (  (freshenv  (cold_fresh_env cold_first_env))
		)
	  (labels 
	   ( (expand-task 
	      (inp)
					; (cold_run_delayed_tasks "start expandtask")
	      (let* ( 
		     (exp (cold_macroexpand inp freshenv)) )
		(cold_delay "normalize after expand" (normalize-task exp)))
	      ; (cold_run_delayed_tasks "end expandtask")
	      )
	     (normalize-task 
	      (exp)
					; (cold_run_delayed_tasks "start normalizetask")
;	      (format *error-output* "stuff to normalize exp=~S of type ~S~%" 
;		      exp (type-of exp))
	      (let ( (normexp (normalize_toplev exp freshenv)) )
		(cold_delay "compile after normalize" (compile-task normexp))
		)
	      (cold_run_delayed_tasks "end normalizetask")
	      )
	     (compile-task
	      (cod)
					; (cold_run_delayed_tasks "start compiletask")
;	      (finish-output outstr)
	      (compile_toplev cod freshenv)
	      (cold_run_delayed_tasks "end compiletask")
	      )
	     )
	   (mapc (lambda (inp) (cold_delay "initial expand" (expand-task inp))) readseq)
	   )				;end of labels
	  (cold_run_delayed_tasks "initial")
					; output the declarations
	  (format *error-output* ";before writing ~d declarations ~g cpusec~%" 
		  (length (compilation-revobjcode this_compilation))
		  (cpusec))
	  (loop
	   for rk from 1
	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
	   do
	   (format outstr "~%~%/*** declobj #~d ***/~%" rk)
	   (output_cdecl ob outstr)
	   ) 
	  (cold_run_delayed_tasks "after decl")
					; output the bodies
	  (format *error-output* ";before writing ~d bodies ~g cpusecs~%" 
		  (length (compilation-revobjcode this_compilation)) (cpusec))
	  (loop
	   for rk from 1
	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
	   do
	   (if (zerop (rem rk 32))
	       (format *error-output* ";;writing body #~d of ~a : ~g cpusecs~%"
		       rk (obj_routine-syname ob) (cpusec)))
	   (format outstr "~%~%~%/*** obj #~d ***/~%" rk)
	   (output_ccode ob outstr)
;	   (finish-output outstr)
	   )
	  (cold_run_delayed_tasks "after bodies")
	  (finish-output outstr)
	  (format *error-output* ";before writing start routine ~g cpusecs~%" (cpusec))
	  (cold_run_delayed_tasks "after initrout preparation")
	  (format outstr "~%~%/*** initial routine is ***/~%")
	  (output_cdecl initrout outstr)
	  (finish-output outstr)
	  (output_ccode initrout outstr)
;	  (finish-output outstr)
	  )
	(format outstr "~%~%/*** end of generated file ~a ***/~%~%" outpathname)
	(finish-output outstr)
	)
       (format *error-output* ";end of generation of ~S in ~g cpusecs~%" 
	       outpathname (cpusec))
       (finish-output *error-output*)
       ))))

(setq *print-circle*  t)


;; eof $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $