added most of my (Basile Starynkevitch's) files

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@132436 138bc75d-0d04-0410-961f-82ee72b054a4

2 files changed, 6918 insertions, 0 deletions

diff --git a/contrib/cold-basilys.lisp b/contrib/cold-basilys.lisp
new file mode 100644
index 00000000000..1c07310b8bf
--- /dev/null
+++ b/contrib/cold-basilys.lisp
@@ -0,0 +1,5422 @@
+;; 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))
+;;-   (let ( (resnorm nil) 
+;;- 	 (sbind (cold_find_binding symb env))
+;;- 	 )
+;;-     (labels 
+;;-      (
+;;-       ( knownsymb
+;;- 	(sym closvars)
+;;- 	(or (symbolp sym) (error "bad symbol ~S in knownsymb" sym))
+;;- 	(some (lambda (cv) (eq (prog_closedvar-clv_var cv) sym)) closvars)
+;;- 	)
+;;-       ( envtest 
+;;- 	(env) 
+;;- 	(or (symbolp symb) (error "bad symbol ~S in envtest" symb))
+;;- 	(let ( (forf (cold_compenv-for env)) ) 
+;;- 	  (cond 
+;;- 	   ( (null forf) 
+;;- 	     (warn "normalize_symbol symb ~S null forf ~%" symb)
+;;- 	     )
+;;- 	   ( (prog_defun-p forf) 
+;;- 	     (or (symbolp symb) (error "bad symbol ~S inside envtest defun forf ~S" symb forf))
+;;- 	     (or resnorm 
+;;- 		 (setq resnorm (make-prog_closedvar :clv_var symb 
+;;- 						    :clv_fun forf 
+;;- 						    :clv_bind sbind)))
+;;- 	     (let ( (oldclosvars (prog_defun-fun_closvars forf)) )
+;;- 	       (or (knownsymb symb oldclosvars)
+;;- 		   (setf (prog_defun-fun_closvars forf) (cons resnorm oldclosvars)))
+;;- 	       )
+;;- 	     )
+;;- 	   ( (prog_lambda-p forf)
+;;- 	     (or (symbolp symb) (error "bad symbol ~S inside envtest lambda forf ~S" symb forf))
+;;- 	     (let ( (oldclosvars (prog_lambda-lambda_closvars forf)) )
+;;- 	       (or resnorm 
+;;- 		   (setq resnorm (make-prog_closedvar :clv_var symb 
+;;- 						      :clv_fun forf
+;;- 						      :clv_bind sbind)))
+;;- 	       (or (knownsymb symb oldclosvars)
+;;- 		   (setf (prog_lambda-lambda_closvars forf) (cons resnorm oldclosvars)))
+;;- 	       )
+;;- 	     )
+;;- 	   ( t
+;;- 	      (error "normalize_symbol ~S strange forf ~S ~%" symb forf)
+;;- 	   )))
+;;- 	t				;as a test, envtest return
+;;- 					;true to continue scan of
+;;- 					;environment lists
+;;- 	)
+;;-       )
+;;-      (or (symbolp symb)
+;;- 	 (error "normalize_symbol bad symb before tested ~s ~%... in env ~s~%" symb env))
+;;-      (if (or (cold_class_binding-p sbind)
+;;- 	     (cold_instance_binding-p sbind))
+;;- 	 symb
+;;-        (progn
+;;- 	 (cold_tested_find_binding symb env (function envtest))
+;;- 	 (or resnorm symb)	    ;return value for normalize_symbol
+;;- 	 )))))
+
+(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))
+			  (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 "((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));~% else goto lab_endargs;~%"
+		(- rk 1))
+	)
+      )
+;    (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)
+    )
+  )
+
+
+;;; 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)))
+
+(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)
+      ))
+
+
+(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 "curfram__.varptr[~d]" o)
+    )
+)
+
+(defmethod query_ctype ((obj obj_ptrvar))
+':value)
+
+
+
+(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 "curfram__.varnum[~d]" o)
+    )
+  )
+
+
+(defmethod output_ccode ((obj obj_closetq) str)
+  (let ((d (obj_closetq-cldest obj))
+	(s (obj_closetq-val obj)))
+    (or (obj_closedvar 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(curfram__.clos, 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*/ curfram__.clos->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 "curfram__.clos->rout->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 ";~%")
+		       )
+		((: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_callcannot 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)))
+      (format str "/*noptrappl*/")
+      (output_ccode dest str)
+      (format str " = "))
+     )
+    (format str "basilysgc_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 ";~%")
+		       )
+		((:value nil)  (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
+		 (output_ccode arg str)
+		 (push "BPARSTR_PTR" revargtypeseq)
+		 (format str ");~%"))
+		(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*/ curfram__.varptr[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*/ curfram__.varptr[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_rptr)~%     *(xrestab_[~d].bp_rptr) = (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
+  freevptrs				;list of free varptr to be reused
+  freevnums				;list of free varlong to be reused
+  freevdbls				;list of free vardbl 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))
+	 (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 "    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 _spare_;")
+    (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 "}, ~%")
+      ) 
+    (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
+))
+
+
+(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\", curfram__.varptr[0]);~%")
+    (format str " basilys_topframe= (void*)(curfram__.prev); return curfram__.varptr[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 
+		 :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)
+		  ) )
+       ( doit (b)			;handle both
+	      (case (cold_formal_binding-type b)
+		    (:value (doptr b))
+		    (:long (dolong 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 ( (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)
+	(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*/ 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*/ 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)
+  (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))
+
+(defun handle-source-file (filename)
+  (with-open-file
+   (istr filename)
+   (format *error-output* "reading file ~s ~%" filename)
+   (let ( (*readtable* (copy-readtable)) 
+	  (readrevseq nil)
+	  (outpathname (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 "/*** 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")
+	      (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)
+	  )
+	(finish-output outstr)
+	(format outstr "~%~%/*** end of generated file ~a ***/~%~%" outpathname)
+	)
+       (format *error-output* ";end of generation of ~S in ~g cpusecs- before basilys-gcc compilation~%" 
+	       outpathname (cpusec))
+       (finish-output *error-output*)
+       #+CLISP
+       (progn 
+	 (ext:run-program "indent" :arguments (list outpathname))
+	 (ext:run-program "basilys-gcc" :arguments (list outpathname))
+	 )
+       #+SBCL
+       (progn
+	 (sb-ext:run-program "/usr/bin/indent" (list outpathname))
+	 (sb-ext:run-program "/home/basile/scripts/basilys-gcc" (list outpathname))
+	 )
+       (format *error-output* ";end of basilys-gcc compilation of ~S in ~g cpusec~%" outpathname (cpusec))
+       (finish-output *error-output*)
+       ))))
+
+(setq *print-circle*  t)
+
+
+;; eof $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $
diff --git a/contrib/simple-probe.c b/contrib/simple-probe.c
new file mode 100644
index 00000000000..96b51d78d2b
--- /dev/null
+++ b/contrib/simple-probe.c
@@ -0,0 +1,1496 @@
+/* Simple probe example (with GTK)
+   Copyright (C) 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 2, 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 COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+/*
+This standalone program is a simple compiler probe client - it is a
+single source file using gtksourceview & gtk; it is not compiled by
+the GCC building process. The compilation command is given near the
+end of file (as a local.var to emacs)
+*/
+
+#define _GNU_SOURCE
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <string.h>
+#include <sys/mman.h>
+#include <ctype.h>
+
+#include <glib.h>
+#include <glib/gprintf.h>
+#include <gtk/gtk.h>
+#include <gtk/gtktextbuffer.h>
+#include <gtksourceview/gtksourceview.h>
+#include <gtksourceview/gtksourcelanguage.h>
+#include <gtksourceview/gtksourcelanguagesmanager.h>
+
+#define PROBE_PROTOCOL_NUMBER 200701
+
+/* from /usr/share/xemacs21/xemacs-packages/etc/ediff/ediff-next.xpm */
+/* XPM */
+static const char *arrow_right_15x15_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "15 15 5 1",
+  " 	c Gray75 s backgroundToolBarColor",
+  ".	c black",
+  "X	c white",
+  "o	c black",
+  "O	c black",
+  "               ",
+  "       .       ",
+  "       ..      ",
+  "       .X.     ",
+  " .......XX.    ",
+  " .XXXXXXXoX.   ",
+  " .XooooooooX.  ",
+  " .Xoooooooooo. ",
+  " .XooooooooO.  ",
+  " .oOOOOOOoO.   ",
+  " .......OO.    ",
+  "       .O.     ",
+  "       ..      ",
+  "       .       ",
+  "               ",
+};
+GdkPixbuf *arrow_right_15x15_pixbuf;
+
+/* from  /usr/share/xemacs21/xemacs-packages/etc/smilies/indifferent.xpm */
+static const char *indifferent_13x14_xpm[] = {
+  "13 14 3 1",
+  "       c None",
+  ".      c #000000",
+  "+      c #FFDD00",
+  "   .......   ",
+  "  ..+++++..  ",
+  " .+++++++++. ",
+  ".+++++++++++.",
+  ".++..+++..++.",
+  ".++..+++..++.",
+  ".+++++++++++.",
+  ".+++++++++++.",
+  ".+++++++++++.",
+  ".++.......++.",
+  ".+++++++++++.",
+  " .+++++++++. ",
+  "  ..+++++..  ",
+  "   .......   "
+};
+GdkPixbuf *indifferent_13x14_pixbuf;
+
+/* from /usr/share/xemacs21/xemacs-packages/lisp/speedbar/sb-info.xpm */
+/* XPM */
+static const char *sb_info_10x15_xpm[] = {
+  "10 15 4 1",
+  " 	c None",
+  ".	c #BEBEBE",
+  "+	c #0000FF",
+  "@	c #FFFFFF",
+  "    ..    ",
+  "  ..+++.  ",
+  " .+++@++. ",
+  " .+++++++ ",
+  " .+++++++ ",
+  ".++@@@++++",
+  ".++++@++++",
+  ".++++@++++",
+  ".++++@++++",
+  " .+++@++++",
+  " .+++@+++ ",
+  " .+@@@@@+ ",
+  " .+++++++ ",
+  "  .+++++  ",
+  "    ++    "
+};
+GdkPixbuf *sb_info_10x15_pixbuf;
+
+/* from  /usr/share/xemacs21/xemacs-packages/etc/xwem/mini-info.xpm */
+/* XPM */
+static const char *mini_info_12x14_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "12 14 3 1",
+/* colors */
+  " 	c None",
+  ".	c #cccc00",
+  "#	c #dddd00",
+/* pixels */
+  "  .#.       ",
+  "  ###       ",
+  "  .#.       ",
+  "            ",
+  "  ...       ",
+  ".###.       ",
+  "..##.       ",
+  " .##.       ",
+  ".###        ",
+  ".##.  .# .# ",
+  ".##.  ######",
+  "###..  #. #.",
+  "####. ####. ",
+  ".#..  .# ##."
+};
+GdkPixbuf *mini_info_12x14_pixbuf;
+
+
+/* from /usr/lib/sourcenav/share/bitmaps/key.xpm */
+/* XPM */
+const static char *key_7x11_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "7 11 3 1",
+/* colors */
+  " 	c None",
+  ".	c black",
+  "X	c #fefe00",
+/* pixels */
+  " ..... ",
+  ".XXXXX.",
+  ".XX.XX.",
+  ".XXXXX.",
+  " ..XX. ",
+  "  .X.  ",
+  "  .XX. ",
+  "  .X.  ",
+  "  .XX. ",
+  "  .X.  ",
+  "   .   "
+};
+GdkPixbuf *key_7x11_pixbuf;
+
+/* from  /usr/lib/sourcenav/share/bitmaps/tree.xpm */
+/* XPM */
+const static char *tree_24x24_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+  "24 24 7 1 0 0",
+/* colors */
+  " 	s none	m none	c none",
+  ".	s iconColor5	m black	c blue",
+  "X	s iconColor2	m white	c white",
+  "o	s iconColor4	m white	c green",
+  "O	s iconColor1	m black	c black",
+  "+	s iconColor6	m white	c yellow",
+  "@	s iconColor3	m black	c red",
+/* pixels */
+  "                        ",
+  "                 .....  ",
+  "                ..XXX.  ",
+  "         ooooo . .....  ",
+  " OOOOOOOOoXXXo.         ",
+  "         ooooo+         ",
+  "               +        ",
+  "                ++++++  ",
+  "                 +XXX+  ",
+  "                ++++++  ",
+  "         @@@@@ +        ",
+  "        O@XXX@+         ",
+  " OOOOO O @@@@@          ",
+  " OXXXOO                 ",
+  " OOOOO O .....   ooooo  ",
+  "        O.XXX.ooooXXXo  ",
+  "         .....@  ooooo  ",
+  "               @        ",
+  "                @       ",
+  "                 @@@@@  ",
+  "                 @XXX@  ",
+  "                 @@@@@  ",
+  "                        ",
+  "                        "
+};
+GdkPixbuf *tree_24x24_pixbuf;
+
+#ifndef NDEBUG
+FILE *dbgfile;
+#define dbgprintf(Fmt, ...) do{if (dbgfile) { 				\
+      fprintf(dbgfile,"+=simple-probe@%d:" Fmt "\n", (int)__LINE__, ##__VA_ARGS__); \
+      fflush(dbgfile);}}while(0)
+#else
+#define dbgprintf(Fmt, ...) do{}while(0)
+#endif
+
+#define SIMPLE_GTK_TEXTBUFFER(B) GTK_TEXT_BUFFER(B)
+
+GHashTable *action_table;
+
+GtkWidget *window, *vbox, *notebook, *mainlabel, *stabar;
+GtkWidget *menubar, *versionlab, *aboutdialog;
+GtkTextBuffer *tractxtbuf;	/* the textbuffer for trace */
+GtkWidget *tracwindow;		/* trace window */
+GtkWidget *tracbox;		/* trace box */
+GtkWidget *traccheck;		/* check button for scroll following */
+GtkWidget *tracscroll;		/* the scrollbox for trace */
+GtkWidget *tracview;		/* the textview for trace */
+GtkTextTagTable *tractagtbl;	/* tag table for trace */
+GtkTextTag *tractag_tim;	/* tag for time display & requests/commands counters */
+GtkTextTag *tractag_title;	/* tag for title display */
+GtkTextTag *tractag_imp;	/* tag for important display */
+GtkTextTag *tractag_in;		/* tag for input display */
+GtkTextTag *tractag_out;	/* tag for output display */
+
+int trac_followout;		/* flag toggled by traccheck to scroll output */
+
+GtkSourceLanguagesManager *lang_mgr;
+
+struct fileinfo_st
+{
+  int fi_rank;			/* positive index inside fileinfo_array */
+  char *fi_path;		/* strdup-ed file path */
+  GtkWidget *fi_srcview;	/* main source view */
+  GtkSourceBuffer *fi_srcbuf;	/* source buffer */
+};
+GPtrArray *fileinfo_array;
+
+
+struct pointinfo_st
+{
+  int pi_rank;			/* rank of this pointinfo in pointinfo_array */
+  int pi_filenum;		/* file number in fileinfo_array */
+  int pi_line;			/* line number */
+  GtkTextChildAnchor *pi_txanchor;	/* text anchor */
+  GtkWidget *pi_txbutton;	/* button (in text) inside anchor */
+};
+GPtrArray *pointinfo_array;
+
+struct dialogitem_st
+{
+  int di_rank;			/* rank of this item in the dialog menu */
+  struct infodialog_st *di_dialog;	/* owning info dialog */
+};
+
+struct infodialog_st
+{
+  int id_rank;			/* rank of this infodialog in infodialog_array */
+  int id_pinfrank;		/* originating point info rank */
+  GtkWidget *id_dialog;		/* the dialog widget */
+  GtkWidget *id_showcombo;	/* the combo widget to show */
+  GtkWidget *id_menubar;	/* the mavigation menubar inside the widget */
+  GtkWidget *id_infolab;	/* the information label inside the dialog */
+  GPtrArray *id_showitems;	/* array of dialogitem-s for show combo */
+  GPtrArray *id_navitems;	/* array dialogitem-s for navigation */
+  GtkWidget *id_navtitle;	/* the navigation title item in menubar */
+  GtkWidget *id_navmenu;	/* the navigation menu */
+  GtkTooltips *id_tooltips;	/* the dialog tooltips */
+};
+GPtrArray *infodialog_array;
+
+
+guint stid_pass;
+
+typedef void action_handler_t (GString * act, void *data);
+
+struct action_entry_st
+{
+  action_handler_t *handler;
+  void *data;
+};
+
+/* requests are from probe to compiler, single line */
+static void requestprintf (const char *fmt, ...)
+  __attribute__ ((format (printf, 1, 2)));
+
+static void
+register_action (const char *action, action_handler_t * handler, void *data)
+{
+  struct action_entry_st *ae = g_malloc0 (sizeof (struct action_entry_st));
+  ae->handler = handler;
+  ae->data = data;
+  g_assert (action_table != 0);
+  g_hash_table_insert (action_table, g_strdup (action), ae);
+}
+
+/***
+ * decode an encoded string, return the malloc-ed string and fil *PLEN
+ * with its length and *PEND with the ending pointer
+ ***/
+static char *
+decode_string (const char *s, int *plen, char **pend)
+{
+  char *res = 0;
+  int len = 0, pos = 0, ix = 0;
+  if (!s)
+    return (char *) 0;
+  if (sscanf (s, " STR%d'%n", &len, &pos) > 0 && pos > 0)
+    {
+      res = g_malloc0 (len + 1);
+      s += pos;
+      for (ix = 0; ix < len; ix++)
+	{
+	  char c = *s;
+	  if (c == '%')
+	    {
+	      int d = 0;
+	      char c1, c2;
+	      if ((c1 = s[1]) && isxdigit (c1)
+		  && (c2 = s[2]) && isxdigit (c2))
+		{
+		  d = (((c1 >= '0' && c1 <= '9') ? (c1 - '0')
+			: (c1 >= 'A' && c1 <= 'F') ? (10 + c1 - 'A')
+			: (c1 >= 'a' && c1 <= 'f') ? (10 + c1 - 'a')
+			: 0) << 4)
+		    + ((c2 >= '0' && c2 <= '9') ? (c2 - '0')
+		       : (c2 >= 'A' && c2 <= 'F') ? (10 + c2 - 'A')
+		       : (c2 >= 'a' && c2 <= 'f') ? (10 + c2 - 'a') : 0);
+		  res[ix] = (char) d;
+		  s += 3;
+		}
+	      else
+		goto error;
+	    }
+	  else if (c == '+')
+	    {
+	      res[ix] = ' ';
+	      s++;
+	    }
+	  else if (c > ' ' && c != '\'' && c != '\"')
+	    {
+	      res[ix] = c;
+	      s++;
+	    }
+	  else
+	    goto error;
+	};
+      if (*s != '\'')
+	goto error;
+      s++;
+      if (plen)
+	*plen = len;
+      if (pend)
+	*pend = (char *) s;
+      return res;
+    }
+error:
+  if (res)
+    g_free (res);
+  return 0;
+}
+
+
+/*** follow the trace window by scrolling to end ***/
+void
+trac_follow_end ()
+{
+  if (trac_followout && tracview)
+    {
+      GtkTextIter titer;
+      gtk_text_buffer_get_end_iter (tractxtbuf, &titer);
+      gtk_text_view_scroll_to_iter (GTK_TEXT_VIEW (tracview), &titer,
+				    /*margin */ 0.05,
+				    /*usalign */ FALSE,
+				    /*xalign */ 0.0,
+				    /* yalign */ 0.9);
+    }
+}
+
+gboolean
+delayed_follow_end_oncecb (gpointer data)
+{
+  g_assert (data == NULL);
+  trac_follow_end ();
+  if (tractxtbuf && tracview)
+    gtk_widget_show (tracview);
+  return FALSE;			/* remove this idle callback immediately */
+}
+
+/**************************** actions **************************/
+
+
+static void
+message_act (GString * s, void *d)
+{
+  char *msg = 0, *end = 0;
+  int pos = 0, len = 0;
+  g_assert (d != s);		/* just to use the arguments */
+  dbgprintf ("message action %s", s->str);
+  if (sscanf (s->str, " PROB_message msg: %n", &pos) >= 0 && pos > 0)
+    msg = decode_string (s->str + pos, &len, &end);
+  if (msg)
+    {
+      gtk_statusbar_pop (GTK_STATUSBAR (stabar), stid_pass);
+      gtk_statusbar_push (GTK_STATUSBAR (stabar), stid_pass, msg);
+      gtk_widget_show (stabar);
+      g_free (msg);
+    }
+  else
+    dbgprintf ("invalid message action %s", s->str);
+}
+
+static void
+version_act (GString * s, void *d)
+{
+  char *msg = 0, *markup = 0, *end = 0;
+  int pos = -1, len = 0, protonum = 0;
+  g_assert (d != s);		/* just to use the arguments */
+  dbgprintf ("version action %s", s->str);
+  if (sscanf (s->str, " PROB_version proto: %d msg:%n", &protonum, &pos) >= 0
+      && pos > 0) 
+    msg = decode_string (s->str + pos, &len, &end);
+  if (protonum != PROBE_PROTOCOL_NUMBER)
+    {
+      dbgprintf ("invalid protocol number %d expecting %d", protonum,
+		 PROBE_PROTOCOL_NUMBER);
+      exit (1);
+    }
+  if (msg)
+    {
+      markup =
+	g_markup_printf_escaped
+	("<small>(protocol %d)</small> - GCC "
+	 "<span style='italic' foreground='darkgreen'>" "%s" "</span>",
+	 protonum, msg);
+      gtk_label_set_markup (GTK_LABEL (versionlab), markup);
+      gtk_widget_show_all (window);
+      g_free (markup);
+    }
+  else
+    dbgprintf ("invalid version action (pos%d protonum%d no msg): %s",
+	       pos, protonum, s->str);
+  
+}
+
+
+static void
+file_act (GString * s, void *d)
+{
+  int filerank = -1, pos = -1, len = 0;
+  int fd = -1;
+  char *file_path = 0, *end = 0;
+  gchar *basename = 0;
+  gchar *mime_type = 0;
+  char *suffix = 0, *markup = 0;
+  GtkSourceLanguage *language = NULL;
+  GtkSourceBuffer *srcbuf = NULL;
+  GtkWidget *srcview = NULL;
+  GtkWidget *scrolwin = NULL;
+  GtkWidget *label = NULL;
+  GtkWidget *tablab = NULL;
+  GtkWidget *box = NULL;
+  struct stat filestat;
+  struct fileinfo_st *filinf = NULL;
+  const gchar *fcontent = 0;
+  size_t filesize = 0;
+  size_t mapsize = 0;
+  static size_t pgsiz;
+  g_assert (d != s);		/* just to use the arguments */
+  memset (&filestat, 0, sizeof (filestat));
+  if (sscanf (s->str, " PROB_file rank: %d fpath: %n", &filerank, &pos)
+      > 0 && filerank >= 0 && pos > 0)
+    {
+      file_path = decode_string (s->str + pos, &len, &end);
+      if ((fd = open (file_path, O_RDONLY)) < 0)
+	{
+	  dbgprintf ("failed to open %s : %m", file_path);
+	  return;
+	}
+      basename = g_path_get_basename ((const gchar *) file_path);
+      suffix = g_strrstr (basename, (const gchar *) ".");
+      if (!strcmp (suffix, ".cc")
+	  || !strcmp (suffix, ".cxx")
+	  || !strcmp (suffix, ".cpp")
+	  || !strcmp (suffix, ".cp")
+	  || !strcmp (suffix, ".ii")
+	  || !strcmp (suffix, ".CPP")
+	  || !strcmp (suffix, ".hh")
+	  || !strcmp (suffix, ".hxx")
+	  || !strcmp (suffix, ".hpp")
+	  || !strcmp (suffix, ".C") || !strcmp (suffix, ".H"))
+	mime_type = "text/x-c++src";
+      else if (!strcmp (suffix, ".c")
+	       || !strcmp (suffix, ".i") || !strcmp (suffix, ".h"))
+	mime_type = "text/x-csrc";
+      else if (!strcmp (suffix, ".f")
+	       || !strcmp (suffix, ".F")
+	       || !strcmp (suffix, ".FOR")
+	       || !strcmp (suffix, ".F77")
+	       || !strcmp (suffix, ".f77")
+	       || !strcmp (suffix, ".F95")
+	       || !strcmp (suffix, ".f95")
+	       || !strcmp (suffix, ".F90")
+	       || !strcmp (suffix, ".f90") || !strcmp (suffix, ".for"))
+	mime_type = "text/x-fortran";
+      else if (!strcmp (suffix, ".adb")
+	       || !strcmp (suffix, ".ads") || !strcmp (suffix, ".ada"))
+	mime_type = "text/x-ada";
+      if (!mime_type)
+	mime_type = "text/x-c++src";
+      dbgprintf ("file %s mimetype %s", file_path, mime_type);
+      if (!fstat (fd, &filestat))
+	filesize = filestat.st_size;
+      language =
+	gtk_source_languages_manager_get_language_from_mime_type (lang_mgr,
+								  mime_type);
+      g_assert (language != NULL);
+      srcbuf = gtk_source_buffer_new_with_language (language);
+      srcview = gtk_source_view_new_with_buffer (srcbuf);
+      g_object_set (G_OBJECT (srcview), "editable", FALSE, NULL);
+      gtk_source_buffer_set_highlight (srcbuf, TRUE);
+      gtk_source_buffer_begin_not_undoable_action (srcbuf);
+      if (!pgsiz)
+	pgsiz = getpagesize ();
+      if (filesize > (off_t) 0)
+	{
+	  gchar *convcont = 0;
+	  gsize convsize = 0;
+	  mapsize = filesize;
+	  if (mapsize % pgsiz)
+	    mapsize = (filesize | (pgsiz - 1)) + 1;
+	  fcontent = (const gchar *) mmap ((void *) 0, mapsize, PROT_READ,
+					   MAP_SHARED, fd, (off_t) 0);
+	  if (fcontent != MAP_FAILED)
+	    {
+	      convcont =
+		g_locale_to_utf8 (fcontent, filesize, NULL, &convsize,
+				  (GError **) 0);
+	      g_assert (convcont);
+	      if (convcont)
+		gtk_text_buffer_set_text (SIMPLE_GTK_TEXTBUFFER (srcbuf),
+					  convcont, convsize);
+	      g_free (convcont);
+	      munmap ((char *) fcontent, mapsize);
+	      fcontent = 0;
+	    }
+	  else
+	    fprintf (stderr, "mmap file %s size %ld failed: %m\n",
+		     file_path, filesize);
+	};
+      close (fd);
+      gtk_source_buffer_end_not_undoable_action (srcbuf);
+      gtk_source_view_set_show_line_numbers (GTK_SOURCE_VIEW (srcview), TRUE);
+      gtk_source_view_set_show_line_markers (GTK_SOURCE_VIEW (srcview), TRUE);
+      markup = g_markup_printf_escaped
+	("<span weight=\"bold\" size=\"larger\">%d</span>\n"
+	 "<small><tt>%s</tt></small>", filerank, basename);
+      tablab = gtk_label_new ((char *) 0);
+      gtk_label_set_markup (GTK_LABEL (tablab), markup);
+      g_free (markup);
+      label = gtk_label_new ((char *) 0);
+      markup = g_markup_printf_escaped
+	("<span weight=\"bold\" size=\"larger\">#%d</span>\n"
+	 "<span color='navy' style='italic'>file "
+	 "<small><tt>%s</tt></small>\n"
+	 "of %ld bytes</span>", filerank, file_path, (long) filesize);
+      gtk_label_set_markup (GTK_LABEL (label), markup);
+      g_free (markup);
+      g_free (basename);
+      basename = suffix = markup = NULL;
+      scrolwin = gtk_scrolled_window_new (NULL, NULL);
+      gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (scrolwin),
+				      GTK_POLICY_NEVER, GTK_POLICY_AUTOMATIC);
+      gtk_container_add (GTK_CONTAINER (scrolwin), srcview);
+      box = gtk_vbox_new (FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (box), label, FALSE, FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (box), scrolwin, TRUE, TRUE, 1);
+      gtk_notebook_insert_page (GTK_NOTEBOOK (notebook), box, tablab,
+				(gint) filerank);
+      if (fileinfo_array->len <= filerank)
+	g_ptr_array_set_size (fileinfo_array, 5 * filerank / 4 + 16);
+      filinf = g_malloc0 (sizeof (*filinf));
+      g_assert (g_ptr_array_index (fileinfo_array, filerank) == NULL);
+      g_ptr_array_index (fileinfo_array, filerank) = filinf;
+      filinf->fi_rank = filerank;
+      filinf->fi_path = g_strdup (file_path);
+      filinf->fi_srcview = srcview;
+      filinf->fi_srcbuf = srcbuf;
+      gtk_source_view_set_marker_pixbuf (GTK_SOURCE_VIEW (srcview), "info",
+					 sb_info_10x15_pixbuf);
+      gtk_widget_show_all (window);
+      g_free (file_path);
+    }
+}
+
+/* GTK callback called when an info dialog is responded */
+static void
+infodialog_cb (GtkWidget * widget, int respid, gpointer data)
+{
+  struct infodialog_st *dia = data;
+  g_assert (dia && dia->id_dialog == widget);
+  switch (respid)
+    {
+    case GTK_RESPONSE_ACCEPT:
+      requestprintf ("prob_UPDATEINFODIALOG dia:%d\n", dia->id_rank);
+      break;
+    case GTK_RESPONSE_CLOSE:
+    default:
+      requestprintf ("prob_REMOVEINFODIALOG dia:%d\n", dia->id_rank);
+      gtk_widget_hide (dia->id_dialog);
+      break;
+    }
+}
+
+/* internal routine to create a new info dialog (still empty and not
+   displayed) */
+static struct infodialog_st *
+make_infodialog (struct pointinfo_st *pi)
+{
+  int ix = 0, k;
+  struct infodialog_st *dia = NULL;
+  struct fileinfo_st *fi = NULL;
+  GtkWidget *dialog = NULL, *hbox = NULL, *menubar = NULL, *combo = NULL,
+    *showlabel = NULL, *pointlabel = NULL, *infolabel = NULL,
+    *infoscroll = NULL;
+  GtkTooltips *tooltips = NULL;
+  char titbuf[64];
+  char *pointmarkup = 0;
+  g_assert (pi != NULL && pi->pi_rank >= 0
+	    && pi->pi_rank < pointinfo_array->len);
+  g_assert (g_ptr_array_index (pointinfo_array, pi->pi_rank) == pi);
+  g_assert (pi->pi_filenum >= 0 && fileinfo_array
+	    && pi->pi_filenum < fileinfo_array->len);
+  fi = g_ptr_array_index (fileinfo_array, pi->pi_filenum);
+  dia = g_malloc0 (sizeof (*dia));
+  memset (titbuf, 0, sizeof (titbuf));
+  ix = -1;
+  if (infodialog_array)
+    {
+      for (k = 0; k < infodialog_array->len; k++)
+	if (!g_ptr_array_index (infodialog_array, k))
+	  {
+	    ix = k;
+	    break;
+	  }
+    }
+  if (ix >= 0)
+    {
+      dia->id_rank = ix;
+      g_ptr_array_index (infodialog_array, ix) = dia;
+    }
+  else
+    {
+      dia->id_rank = infodialog_array->len;
+      g_ptr_array_add (infodialog_array, dia);
+    }
+  dbgprintf ("make_infodialog dia %p rank %d", dia, dia->id_rank);
+  dia->id_pinfrank = pi->pi_rank;
+  snprintf (titbuf, sizeof (titbuf) - 1, "InfoPt#%d", dia->id_rank);
+  dialog = dia->id_dialog
+    = gtk_dialog_new_with_buttons
+    (titbuf,
+     GTK_WINDOW (window),
+     GTK_DIALOG_DESTROY_WITH_PARENT,
+     GTK_STOCK_HOME, GTK_RESPONSE_ACCEPT,
+     GTK_STOCK_CLOSE, GTK_RESPONSE_CLOSE, NULL);
+  tooltips = dia->id_tooltips = gtk_tooltips_new ();
+  pointlabel = gtk_label_new ((char *) 0);
+  pointmarkup = g_markup_printf_escaped
+    ("<span size='large' foreground='darkgreen'>"
+     "info point #%d" "</span>\n"
+     "<b>file #%d</b> <tt>%s</tt> <i>line %d</i>",
+     dia->id_rank, pi->pi_filenum, fi->fi_path, pi->pi_line);
+  gtk_label_set_markup (GTK_LABEL (pointlabel), pointmarkup);
+  g_free (pointmarkup);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      pointlabel, /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  hbox = gtk_hbox_new (FALSE, 3);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      hbox, /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  showlabel = gtk_label_new ((char *) 0);
+  gtk_label_set_markup (GTK_LABEL (showlabel),
+			"<span foreground='navy' weight='bold'>"
+			"show:" "</span>");
+  gtk_box_pack_start (GTK_BOX (hbox), showlabel,
+		      /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  combo = dia->id_showcombo = gtk_combo_box_new_text ();
+  gtk_tooltips_set_tip (tooltips, combo,
+			"Select information to show",
+			"Choose the information to show in this dialog\n"
+			"for this info point");
+  gtk_box_pack_start (GTK_BOX (hbox), combo,
+		      /*expand: */ TRUE, /*fill: */ TRUE,
+		      1);
+  menubar = dia->id_menubar = gtk_menu_bar_new ();
+  gtk_tooltips_set_tip (tooltips, menubar,
+			"Navigation menu",
+			"Choose where to go in this dialog\n"
+			"for this info point");
+  gtk_box_pack_start (GTK_BOX (hbox), menubar,
+		      /*expand: */ FALSE, /*fill: */ FALSE,
+		      2);
+  infoscroll = gtk_scrolled_window_new (NULL, NULL);
+  gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (infoscroll),
+				  GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
+  dia->id_infolab = infolabel = gtk_label_new ((char *) 0);
+  gtk_label_set_markup (GTK_LABEL (infolabel),
+			"<span size='large' foreground='darkred'>"
+			"* select info to show *" "</span>\n");
+  gtk_label_set_selectable (GTK_LABEL (infolabel), TRUE);
+  gtk_scrolled_window_add_with_viewport (GTK_SCROLLED_WINDOW (infoscroll),
+					 infolabel);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      infoscroll, /*expand: */ TRUE, /*fill: */ TRUE, 1);
+  dia->id_showitems = g_ptr_array_sized_new (6);
+  g_signal_connect (G_OBJECT (dialog),
+		    "response", G_CALLBACK (infodialog_cb), dia);
+  dbgprintf ("make_infodialog dia %p rank %d", dia, dia->id_rank);
+  return dia;
+}
+
+
+/* GTK callback called when an info button is clicked; should create a
+   dialog and ask it to be filled */
+static void
+txinfobutton_cb (GtkWidget * widget, gpointer data)
+{
+  struct pointinfo_st *pi = data;
+  struct infodialog_st *dia = NULL;
+  g_assert (pi && pi->pi_txbutton == widget);
+  dia = make_infodialog (pi);
+  requestprintf ("prob_NEWINFODIALOG pt:%d dia:%d\n",
+		 pi->pi_rank, dia->id_rank);
+}
+
+
+/* GTK callback called when about information has been asked */
+static void
+aboutwin_cb (GtkWidget * widget, gpointer data)
+{
+  if (!aboutdialog)
+    {
+      aboutdialog = gtk_about_dialog_new ();
+      gtk_about_dialog_set_name (GTK_ABOUT_DIALOG (aboutdialog),
+				 "GCC simple compiler probe");
+      gtk_about_dialog_set_copyright (GTK_ABOUT_DIALOG (aboutdialog),
+				      "Copyright (C) 2007 Free Software Foundation, Inc");
+      gtk_about_dialog_set_license (GTK_ABOUT_DIALOG (aboutdialog),
+				    "GNU General Public License version 2 or later");
+      gtk_about_dialog_set_website (GTK_ABOUT_DIALOG (aboutdialog),
+				    "http://gcc.gnu.org/");
+      gtk_about_dialog_set_comments (GTK_ABOUT_DIALOG (aboutdialog),
+				     "A simple compiler probe to be used with GCC\n"
+				     " [Gnu Compiler Collection] \n"
+				     "with its -fcompiler-probe option\n"
+				     "(simple-probe built " __DATE__ "@"
+				     __TIME__ ")");
+    };
+  gtk_dialog_run (GTK_DIALOG (aboutdialog));
+}
+
+
+static void
+infopoint_act (GString * s, void *d)
+{
+  int filerk = 0;
+  int lineno = 0;
+  int infonum = 0;
+  struct fileinfo_st *filinf = NULL;
+  struct pointinfo_st *pi = NULL;
+  char *filepath = NULL;
+  GtkTextIter txiter;
+  GtkSourceBuffer *srcbuf = NULL;
+  GtkWidget *srcview = NULL;
+  GtkWidget *txbutton = NULL;
+  GtkTextChildAnchor *anch = NULL;
+  g_assert (s != d);
+  if (sscanf
+      (s->str, " PROB_infopoint fil:%d lin:%d rk:%d", &filerk, &lineno,
+       &infonum) > 0 && infonum >= 0)
+    {
+      dbgprintf ("infopoint act filerk %d lineno %d infonum %d",
+		 filerk, lineno, infonum);
+      memset (&txiter, 0, sizeof (txiter));
+      if (filerk >= 0 && filerk < fileinfo_array->len)
+	filinf = g_ptr_array_index (fileinfo_array, filerk);
+      if (!filinf)
+	return;
+      if (pointinfo_array->len <= infonum)
+	g_ptr_array_set_size (pointinfo_array, 5 * infonum / 4 + 16);
+      if (g_ptr_array_index (pointinfo_array, infonum) != NULL)
+	return;
+      filepath = filinf->fi_path;
+      g_assert (filepath);
+      srcbuf = filinf->fi_srcbuf;
+      srcview = filinf->fi_srcview;
+      g_assert (srcbuf);
+      pi = g_malloc0 (sizeof (struct pointinfo_st));
+      g_ptr_array_index (pointinfo_array, infonum) = pi;
+      pi->pi_rank = infonum;
+      pi->pi_filenum = filerk;
+      pi->pi_line = lineno;
+      gtk_text_buffer_get_iter_at_line (GTK_TEXT_BUFFER (srcbuf), &txiter,
+					lineno - 1);
+      anch =
+	gtk_text_buffer_create_child_anchor (GTK_TEXT_BUFFER (srcbuf),
+					     &txiter);
+      txbutton = gtk_button_new ();
+      gtk_button_set_image (GTK_BUTTON (txbutton),
+			    gtk_image_new_from_pixbuf (key_7x11_pixbuf));
+      gtk_text_view_add_child_at_anchor (GTK_TEXT_VIEW (srcview), txbutton,
+					 anch);
+      gtk_widget_show_all (txbutton);
+      gtk_widget_show_all (srcview);
+      gtk_widget_show_all (window);
+      pi->pi_txanchor = anch;
+      pi->pi_txbutton = txbutton;
+      g_signal_connect (G_OBJECT (txbutton), "clicked",
+			G_CALLBACK (txinfobutton_cb), pi);
+    }
+  else
+    dbgprintf ("invalid infopoint_act %s", s->str);
+}
+
+/* GTK callback of show items */
+static void
+showcombochanged_cb (GtkComboBox * combo, struct infodialog_st *dia)
+{
+  gint rk = -1;
+  g_assert (combo && dia && dia->id_showcombo == GTK_WIDGET (combo));
+  rk = gtk_combo_box_get_active (combo);
+  if (rk >= 0)
+    requestprintf ("prob_SHOWINFODIALOG dia:%d ch:%d\n", dia->id_rank, rk);
+}
+
+static void
+dialogchoice_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1, len = 0, chrk = -1;
+  char *end = 0, *msg = 0;
+  struct infodialog_st *dia = NULL;
+  struct dialogitem_st *itm = NULL;
+  g_assert (s != d);
+  dbgprintf ("dialogchoice_act start %s", s->str);
+  if (sscanf
+      (s->str, " PROB_dialogchoice dia: %d msg: %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialogchoice_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("dialogchoice_act dia %p", dia);
+      msg = decode_string (s->str + pos, &len, &end);
+      if (sscanf (end, " ch: %d", &chrk) <= 0 || chrk < 0)
+	{
+	  g_free (msg);
+	  return;
+	}
+      itm = g_malloc0 (sizeof (*itm));
+      itm->di_rank = chrk;
+      itm->di_dialog = dia;
+      g_ptr_array_add (dia->id_showitems, itm);
+      gtk_combo_box_insert_text (GTK_COMBO_BOX (dia->id_showcombo), chrk,
+				 msg);
+      g_signal_connect (G_OBJECT (dia->id_showcombo), "changed",
+			G_CALLBACK (showcombochanged_cb), (gpointer) dia);
+      g_free (msg);
+      dbgprintf ("dialogchoice_act done dia %p", dia);
+    }
+}
+
+
+static void
+dialogcontent_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1;
+  struct infodialog_st *dia = NULL;
+  char *ps = 0;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_dialogcontent dia: %d %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialogcontent_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      ps = s->str + pos;
+      dbgprintf ("dialogcontent_act dia %p", dia);
+      gtk_label_set_text (GTK_LABEL (dia->id_infolab), ps);
+      /* destroy the navigation items & menu */
+      if (dia->id_navitems)
+	{
+	  g_ptr_array_free (dia->id_navitems, TRUE);
+	  dia->id_navitems = NULL;
+	}
+      if (dia->id_navmenu)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navmenu));
+	  dia->id_navmenu = NULL;
+	}
+      if (dia->id_navtitle)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navtitle));
+	  dia->id_navtitle = NULL;
+	}
+    }
+}
+
+static void
+showdialog_act (GString * s, void *d)
+{
+  int diark = -1;
+  struct infodialog_st *dia = NULL;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_showdialog dia:%d", &diark) > 0 && diark >= 0)
+    {
+      dbgprintf ("showdialog_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("showdialog_act dia %p", dia);
+      gtk_widget_show_all (dia->id_dialog);
+    }
+}
+
+
+/*GTK callback for dialog navigation items */
+static void
+navigitem_cb (GtkMenuItem * menuitem, gpointer data)
+{
+  struct dialogitem_st *itm = data;
+  g_assert (itm != 0 && itm->di_dialog);
+  requestprintf ("prob_NAVIGINFODIALOG dia:%d nav:%d\n",
+		 itm->di_dialog->id_rank, itm->di_rank);
+
+}
+
+
+static void
+dialognavig_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1, len = 0, navrk = -1;
+  char *end = 0, *msg = 0;
+  struct infodialog_st *dia = NULL;
+  struct dialogitem_st *itm = NULL;
+  GtkWidget *menuitem = NULL, *sepitem = NULL, *navigitem = NULL;
+  g_assert (s != d);
+  dbgprintf ("dialognavig_act start %s", s->str);
+  if (sscanf
+      (s->str, " PROB_dialognavig dia: %d msg: %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialognavig_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("dialognavig_act dia %p", dia);
+      msg = decode_string (s->str + pos, &len, &end);
+      if (sscanf (end, " nav: %d", &navrk) <= 0 || navrk < 0)
+	{
+	  dbgprintf ("dialognavig_act bad end %s", end);
+	  g_free (msg);
+	  return;
+	}
+      itm = g_malloc0 (sizeof (*itm));
+      dbgprintf ("dialognavig_act navrk %d msg %s", navrk, msg);
+      itm->di_rank = navrk;
+      itm->di_dialog = dia;
+      if (!dia->id_navitems)
+	dia->id_navitems = g_ptr_array_sized_new (6);
+      g_ptr_array_add (dia->id_navitems, itm);
+      menuitem = gtk_menu_item_new_with_label (msg);
+      if (!dia->id_navmenu)
+	{
+	  dia->id_navmenu = gtk_menu_new ();
+	  dbgprintf ("dialognavig_act navmenu %p", dia->id_navmenu);
+	  sepitem = gtk_separator_menu_item_new ();
+	  gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_navmenu), sepitem);
+	  g_assert (GTK_IS_MENU_SHELL (dia->id_menubar));
+	  navigitem = dia->id_navtitle =
+	    gtk_menu_item_new_with_label ("navigation");
+	  gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_menubar), navigitem);
+	  gtk_menu_item_set_submenu (GTK_MENU_ITEM (navigitem),
+				     dia->id_navmenu);
+	  gtk_widget_show (dia->id_navmenu);
+	}
+      gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_navmenu), menuitem);
+      gtk_widget_show (menuitem);
+      g_free (msg);
+      msg = NULL;
+      g_signal_connect (G_OBJECT (menuitem),
+			"activate", G_CALLBACK (navigitem_cb), itm);
+      dbgprintf ("dialognavig_act done dia %p", dia);
+    }
+}
+
+
+static void
+destroydialog_act (GString * s, void *d)
+{
+  int diark = -1;
+  struct infodialog_st *dia = NULL;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_destroydialog dia: %d", &diark) > 0
+      && diark >= 0)
+    {
+      dbgprintf ("destroydialog_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("destroydialog_act dia %p", dia);
+      if (dia->id_dialog)
+	gtk_widget_hide (dia->id_dialog);
+      if (dia->id_navitems)
+	{
+	  g_ptr_array_free (dia->id_navitems, TRUE);
+	  dia->id_navitems = NULL;
+	}
+      if (dia->id_navmenu)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navmenu));
+	  dia->id_navmenu = NULL;
+	}
+      if (dia->id_navtitle)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navtitle));
+	  dia->id_navtitle = NULL;
+	}
+      gtk_object_destroy (GTK_OBJECT (dia->id_dialog));
+      g_ptr_array_free (dia->id_showitems, TRUE);
+      memset (dia, 0, sizeof (dia));
+      g_ptr_array_index (infodialog_array, diark) = NULL;
+      g_free (dia);
+      dbgprintf ("destroydialog_act done diark%d", diark);
+    }
+}
+
+/*********************** request & trace ***********************/
+static void
+insert_trace_time (int dated, const char *buf)
+{
+  struct
+  {
+    char buf[200];
+    GTimeVal tv;
+    struct tm tm;
+    char sec[10];
+  } t;
+  time_t tim;
+  GtkTextIter itend;
+  memset (&t, 0, sizeof (t));
+  memset (&itend, 0, sizeof (itend));
+  g_get_current_time (&t.tv);
+  tim = t.tv.tv_sec;
+  localtime_r (&tim, &t.tm);
+  strftime (t.buf, sizeof (t.buf) - 10, dated ? " %G %b %d @ %T" : " %T",
+	    &t.tm);
+  sprintf (t.sec, ".%03d ", (int) t.tv.tv_usec / 1000);
+  strcat (t.buf, t.sec);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, "\n", -1,
+				    tractag_tim, (void *) 0);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  if (buf)
+    gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, buf, -1,
+				      tractag_tim, (void *) 0);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, t.buf, -1,
+				    tractag_tim, (void *) 0);
+}
+
+
+static void
+requestprintf (const char *fmt, ...)
+{
+  va_list ar;
+  gchar *buf = 0;
+  gint len = 0;
+  static int nbreq;
+  GtkTextIter itend;
+  char bufn[64];
+  va_start (ar, fmt);
+  nbreq++;
+  len = g_vasprintf (&buf, (const gchar *) fmt, ar);
+  va_end (ar);
+  dbgprintf ("begin requestprintf %.30s", fmt);
+  if (tractxtbuf)
+    {
+      memset (&itend, 0, sizeof (itend));
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      memset (bufn, 0, sizeof (bufn));
+      snprintf (bufn, sizeof (bufn) - 1, "!request %d:", nbreq);
+      insert_trace_time (0, bufn);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, buf, len,
+					tractag_out, (void *) 0);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+    };
+  fputs (buf, stdout);
+  if (len <= 0 || buf[len - 1] != '\n')
+    {
+      putchar ('\n');
+      if (tractxtbuf)
+	gtk_text_buffer_insert (tractxtbuf, &itend, "\n", 1);
+    };
+  fflush (stdout);
+  if (tractxtbuf)
+    {
+      trac_follow_end ();
+      gtk_widget_show_all (tracwindow);
+    }
+  dbgprintf ("request #%d: %s\n", nbreq, buf);
+  g_free (buf);
+  if (tractxtbuf && trac_followout)
+    g_idle_add (delayed_follow_end_oncecb, (void *) 0);
+  buf = 0;
+}
+
+static gboolean
+ioreader (GIOChannel * chan, GIOCondition cond, gpointer data)
+{
+  gchar *end = 0, *line = 0;
+  gsize len = 0;
+  gsize eolpos = 0;
+  GIOStatus stat = 0;
+  GError *err = 0;
+  GString *str = 0;
+  int leftmagic = 0, rightmagic = 0, pos = 0;
+  char verb[64];
+  char bufn[48];
+  static int nbcmd;
+  g_assert (cond == G_IO_IN);
+  line = end = 0;
+  len = eolpos = 0;
+  dbgprintf ("ioreader begin");
+  stat = g_io_channel_read_line (chan, &line, &len, &eolpos, &err);
+  dbgprintf ("ioreader stat %d", stat);
+  if (stat == G_IO_STATUS_NORMAL)
+    {
+      if (line[0] == '!'
+	  && sscanf (line, "!#%x/%X[%n", &leftmagic, &rightmagic, &pos) >= 2
+	  && rightmagic != 0 && pos > 0)
+	{			/* multi-line command */
+	  str = g_string_sized_new (1000 + eolpos);
+	  str = g_string_append (str, line + pos);
+	  g_free (line);
+	  line = 0;
+	  while ((stat =
+		  g_io_channel_read_line (chan, &line, &len, &eolpos,
+					  &err)) == G_IO_STATUS_NORMAL)
+	    {
+	      int left, right;
+	      left = right = pos = 0;
+	      if (line[0] == '!'
+		  && sscanf (line, "!#%x/%X] %n", &left, &right, &pos) >= 2
+		  && pos > 0 && left == leftmagic && right == rightmagic
+		  && line[pos] == '\0')
+		{
+		  g_free (line);
+		  line = 0;
+		  break;
+		};
+	      str = g_string_append (str, line);
+	      g_free (line);
+	      line = 0;
+
+	    };
+	}
+      else
+	{			/* ordinary single line command */
+	  str = g_string_sized_new (1000 + eolpos);
+	  str = g_string_append (str, line);
+	  g_free (line);
+	  line = 0;
+	}
+    }
+  if (str && str->len == 1 && str->str[0] == '\n')
+    return TRUE;
+  nbcmd++;
+  dbgprintf ("command #%d: %s\n", nbcmd, str->str);
+  if (tractxtbuf)
+    {
+      GtkTextIter itend;
+      memset (&itend, 0, sizeof (itend));
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      memset (bufn, 0, sizeof (bufn));
+      snprintf (bufn, sizeof (bufn) - 1, "?command %d:", nbcmd);
+      insert_trace_time (0, bufn);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, str->str,
+					str->len, tractag_in, (void *) 0);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      if (str->len > 0 && str->str[str->len - 1] != '\n')
+	gtk_text_buffer_insert (tractxtbuf, &itend, "\n", 1);
+      trac_follow_end ();
+    };
+  memset (verb, 0, sizeof (verb));
+  if (str && sscanf (str->str, " %62[a-zA-Z0-9_] ", verb) > 0)
+    {
+      struct action_entry_st *ae = g_hash_table_lookup (action_table, verb);
+      dbgprintf ("command verb %s", verb);
+      if (ae && ae->handler)
+	{
+	  (*ae->handler) (str, ae->data);
+	  if (tractxtbuf)
+	    trac_follow_end ();
+	}
+      else if (tractxtbuf)
+	{
+	  static char unknownmsg[200];
+	  GtkTextIter itend;
+	  memset (&itend, 0, sizeof (itend));
+	  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+					&itend);
+	  memset (unknownmsg, 0, sizeof (unknownmsg));
+	  snprintf (unknownmsg, sizeof (unknownmsg) - 1,
+		    "*?* unknown command verb '%s'\n", verb);
+	  dbgprintf ("*? unknown command verb '%s'", verb);
+	  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend,
+					    unknownmsg, strlen (unknownmsg),
+					    tractag_tim, (void *) 0);
+	  trac_follow_end ();
+	}
+      if (tractxtbuf)
+	gtk_widget_show_all (tracwindow);
+    }
+  else
+    dbgprintf ("invalid command string %s", str->str);
+  if (str)
+    g_string_free (str, TRUE);
+  if (tractxtbuf && trac_followout)
+    g_idle_add (delayed_follow_end_oncecb, (void *) 0);
+  str = 0;
+  /* remove the handler on eof */
+  dbgprintf ("stat=%d isnormal=%d", stat, stat != G_IO_STATUS_EOF);
+  /* the function should return FALSE if the event source should be removed. */
+  return stat != G_IO_STATUS_EOF;
+}
+
+static void
+destroy_cb (GtkWidget * widget, gpointer data)
+{
+  requestprintf ("prob_STOP\n");
+  gtk_main_quit ();
+}
+
+static void
+tracdestroy_cb (GtkWidget * widget, gpointer data)
+{
+  g_assert (widget == tracwindow);
+  tracwindow = (void *) 0;
+  tracbox = (void *) 0;
+  tracscroll = (void *) 0;
+  tracview = (void *) 0;
+  tractagtbl = (void *) 0;
+  tractag_tim = tractag_title = tractag_imp = tractag_in = tractag_out = 0;
+  tractxtbuf = 0;
+}
+
+
+static GtkItemFactoryEntry menu_items[] = {
+  {"/_File", NULL, NULL, 0, "<Branch>"},
+  {"/File/_Quit", "<CTRL>Q", gtk_main_quit, 0, "<StockItem>", GTK_STOCK_QUIT},
+  {"/_Help", NULL, NULL, 0, "<LastBranch>"},
+  {"/_Help/About", NULL, aboutwin_cb, 0, "<Item>"},
+};
+
+/* Returns a menubar widget made from the above menu */
+static GtkWidget *
+get_menubar_menu (GtkWidget * window)
+{
+  GtkItemFactory *item_factory;
+  GtkAccelGroup *accel_group;
+
+  /* Make an accelerator group (shortcut keys) */
+  accel_group = gtk_accel_group_new ();
+
+  /* Make an ItemFactory (that makes a menubar) */
+  item_factory = gtk_item_factory_new (GTK_TYPE_MENU_BAR, "<main>",
+				       accel_group);
+
+  /* This function generates the menu items. Pass the item factory,
+     the number of items in the array, the array itself, and any
+     callback data for the the menu items. */
+  gtk_item_factory_create_items (item_factory,
+				 sizeof (menu_items) / sizeof (menu_items[0]),
+				 menu_items, NULL);
+
+  /* Attach the new accelerator group to the window. */
+  gtk_window_add_accel_group (GTK_WINDOW (window), accel_group);
+
+  /* Finally, return the actual menu bar created by the item factory. */
+  return gtk_item_factory_get_widget (item_factory, "<main>");
+}
+
+static void
+trac_toggled_cb (GtkWidget * w, void *data)
+{
+  trac_followout = !trac_followout;
+  trac_follow_end ();
+}
+
+int
+main (int argc, char *argv[])
+{
+  GIOChannel *chan = 0;
+  GtkSourceLanguagesManager *lm;
+  guint inputio;
+  int traced = 0, ix;
+  GError *err = 0;
+  char buf[200];
+  char hn[64];
+  /* initialization */
+  gtk_init (&argc, &argv);
+  for (ix = 1; ix < argc; ix++)
+    {
+      if (!strcmp (argv[ix], "--traced") || !strcmp (argv[ix], "-T"))
+	traced = 1;
+#ifndef NDEBUG
+      if (!strcmp (argv[ix], "--debug") || !strcmp (argv[ix], "-D"))
+	dbgfile = stderr;
+#endif
+    }
+  arrow_right_15x15_pixbuf =
+    gdk_pixbuf_new_from_xpm_data (arrow_right_15x15_xpm);
+  indifferent_13x14_pixbuf =
+    gdk_pixbuf_new_from_xpm_data (indifferent_13x14_xpm);
+  sb_info_10x15_pixbuf = gdk_pixbuf_new_from_xpm_data (sb_info_10x15_xpm);
+  mini_info_12x14_pixbuf = gdk_pixbuf_new_from_xpm_data (mini_info_12x14_xpm);
+  key_7x11_pixbuf = gdk_pixbuf_new_from_xpm_data (key_7x11_xpm);
+  tree_24x24_pixbuf = gdk_pixbuf_new_from_xpm_data (tree_24x24_xpm);
+  action_table = g_hash_table_new (g_str_hash, g_str_equal);
+  lm = gtk_source_languages_manager_new ();
+  chan = g_io_channel_unix_new (STDIN_FILENO);
+  g_io_channel_set_encoding (chan, (const gchar *) "latin1", &err);
+  inputio = g_io_add_watch (chan, G_IO_IN, ioreader, (gpointer) 0);
+  window = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+  gtk_container_set_border_width (GTK_CONTAINER (window), 1);
+  gtk_window_set_default_size (GTK_WINDOW (window), 450, 300);
+  gtk_window_set_title (GTK_WINDOW (window), "simple GCC probe");
+  vbox = gtk_vbox_new (FALSE, 2);
+  gtk_container_add (GTK_CONTAINER (window), vbox);
+  menubar = get_menubar_menu (window);
+  gtk_box_pack_start (GTK_BOX (vbox), menubar, FALSE, TRUE, 1);
+  gethostname (hn, sizeof (hn));
+  snprintf (buf, sizeof (buf), "GCC simple probe pid %d on %s",
+	    (int) getpid (), hn);
+  buf[sizeof (buf) - 1] = 0;
+  fileinfo_array = g_ptr_array_sized_new (200);
+  pointinfo_array = g_ptr_array_sized_new (400);
+  infodialog_array = g_ptr_array_sized_new (300);
+  mainlabel = gtk_label_new (buf);
+  gtk_box_pack_start (GTK_BOX (vbox), mainlabel, FALSE, FALSE, 1);
+  versionlab = gtk_label_new ((char *) 0);
+  gtk_label_set_selectable (GTK_LABEL (versionlab), TRUE);
+  gtk_box_pack_start (GTK_BOX (vbox), versionlab, FALSE, FALSE, 1);
+  notebook = gtk_notebook_new ();
+  gtk_notebook_set_scrollable (GTK_NOTEBOOK (notebook), TRUE);
+  gtk_box_pack_start (GTK_BOX (vbox), notebook, TRUE, TRUE, 1);
+  stabar = gtk_statusbar_new ();
+  stid_pass =
+    gtk_statusbar_get_context_id (GTK_STATUSBAR (stabar), "passctx");
+  gtk_statusbar_push (GTK_STATUSBAR (stabar), stid_pass, "no pass");
+  gtk_box_pack_start (GTK_BOX (vbox), stabar, FALSE, FALSE, 1);
+  lang_mgr = gtk_source_languages_manager_new ();
+  g_signal_connect (G_OBJECT (window), "destroy",
+		    G_CALLBACK (destroy_cb), NULL);
+  register_action ("PROB_destroydialog", destroydialog_act, (void *) 0);
+  register_action ("PROB_dialogchoice", dialogchoice_act, (void *) 0);
+  register_action ("PROB_dialogcontent", dialogcontent_act, (void *) 0);
+  register_action ("PROB_dialognavig", dialognavig_act, (void *) 0);
+  register_action ("PROB_file", file_act, (void *) 0);
+  register_action ("PROB_infopoint", infopoint_act, (void *) 0);
+  register_action ("PROB_message", message_act, (void *) 0);
+  register_action ("PROB_showdialog", showdialog_act, (void *) 0);
+  register_action ("PROB_version", version_act, (void *) 0);
+  if (traced)
+    {
+      char buf[100];
+      memset (buf, 0, sizeof (buf));
+      snprintf (buf, sizeof (buf) - 1, "GCC simple probe trace pid %ld",
+		(long) getpid ());
+      tracwindow = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+      gtk_window_set_default_size (GTK_WINDOW (tracwindow), 500, 400);
+      g_signal_connect (G_OBJECT (tracwindow), "destroy",
+			G_CALLBACK (tracdestroy_cb), NULL);
+      gtk_container_set_border_width (GTK_CONTAINER (tracwindow), 1);
+      gtk_window_set_title (GTK_WINDOW (tracwindow), "simple GCC trace");
+      tracbox = gtk_vbox_new (FALSE, 2);
+      dbgprintf ("tracbox %p", tracbox);
+      traccheck =
+	gtk_check_button_new_with_label ("autoscroll follow output");
+      g_signal_connect (traccheck, "toggled", G_CALLBACK (trac_toggled_cb),
+			NULL);
+      gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON (traccheck), 1);
+      tracscroll = gtk_scrolled_window_new (0, 0);
+      gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (tracscroll),
+				      GTK_POLICY_NEVER, GTK_POLICY_AUTOMATIC);
+      gtk_container_add (GTK_CONTAINER (tracwindow), tracbox);
+      gtk_box_pack_start (GTK_BOX (tracbox), gtk_label_new (buf), FALSE,
+			  FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (tracbox), traccheck, FALSE, FALSE, 1);
+      tractagtbl = gtk_text_tag_table_new ();
+      dbgprintf ("tractagtbl %p", tractagtbl);
+      tractxtbuf = gtk_text_buffer_new (tractagtbl);
+      dbgprintf ("tractxtbuf %p", tractxtbuf);
+      tractag_tim = gtk_text_buffer_create_tag (tractxtbuf, "tim",
+						"weight", PANGO_WEIGHT_BOLD,
+						"scale", PANGO_SCALE_SMALL,
+						"foreground",
+						"DarkGoldenrod4", (void *) 0);
+      tractag_title =
+	gtk_text_buffer_create_tag (tractxtbuf, "title", "scale",
+				    PANGO_SCALE_X_LARGE, "foreground", "red",
+				    (void *) 0);
+      tractag_imp =
+	gtk_text_buffer_create_tag (tractxtbuf, "imp", "scale",
+				    PANGO_SCALE_LARGE, "weight",
+				    PANGO_WEIGHT_BOLD, "foreground", "red",
+				    (void *) 0);
+      tractag_in =
+	gtk_text_buffer_create_tag (tractxtbuf, "in", "foreground", "blue",
+				    (void *) 0);
+      tractag_out =
+	gtk_text_buffer_create_tag (tractxtbuf, "out", "style",
+				    PANGO_STYLE_ITALIC, "foreground",
+				    "darkgreen", (void *) 0);
+      tracview = gtk_text_view_new_with_buffer (tractxtbuf);
+      dbgprintf ("tracview %p", tracview);
+      gtk_text_view_set_editable (GTK_TEXT_VIEW (tracview), FALSE);
+      gtk_text_view_set_wrap_mode (GTK_TEXT_VIEW (tracview), GTK_WRAP_CHAR);
+      dbgprintf ("tracscroll %p", tracscroll);
+      gtk_container_add (GTK_CONTAINER (tracscroll), tracview);
+      dbgprintf ("tracbox %p", tracbox);
+      gtk_box_pack_start (GTK_BOX (tracbox), tracscroll, TRUE, TRUE, 1);
+      insert_trace_time (1, "TRACE [compiled " __DATE__ "@" __TIME__ "]: ");
+      gtk_widget_show_all (tracwindow);
+    };
+  gtk_widget_show_all (window);
+  gtk_main ();
+  return 0;
+}
+
+/**** for emacs 
+  ++ Local Variables: ++
+  ++ compilation-directory: "." ++
+  ++ compile-command: "gcc -Wall -O -g $(pkg-config --cflags --libs gtksourceview-1.0 gtk+-2.0) -o $HOME/bin/simple-probe simple-probe.c" ++
+  ++ End: ++
+ ****/
+
+/* eof simple-probe.c */