2008-06-06 Basile Starynkevitch <basile@starynkevitch.net>

	* contrib/cold-basilys.lisp: REMOVED FILE.



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

2 files changed, 3 insertions, 5515 deletions

diff --git a/contrib/ChangeLog.melt b/contrib/ChangeLog.melt
index ff5e8e3de2e..ca6a5f502f0 100644
--- a/contrib/ChangeLog.melt
+++ b/contrib/ChangeLog.melt
@@ -1,5 +1,8 @@
 
 2008-06-06  Basile Starynkevitch  <basile@starynkevitch.net>
+	* cold-basilys.lisp: REMOVED FILE.
+
+2008-06-06  Basile Starynkevitch  <basile@starynkevitch.net>
 	* cold-basilys.lisp: obsolete file.
 
 2008-05-22  Basile Starynkevitch  <basile@starynkevitch.net>
diff --git a/contrib/cold-basilys.lisp b/contrib/cold-basilys.lisp
deleted file mode 100644
index 22911646258..00000000000
--- a/contrib/cold-basilys.lisp
+++ /dev/null
@@ -1,5515 +0,0 @@
-;; 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.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(error "this file is obsolete - use warm-basilys-0 instead!")
-
-;; conventionally, our names contain underscores _ so the minus sign -
-;; is only in CommonLisp names, in particular in names generated by
-;; defstruct
-
-(defvar this_compilation nil "the current compilation")
-
-(warn "should add disc_super to class_discr")
-
-(defun cpusec () (float (/ (get-internal-run-time) internal-time-units-per-second )))
-
-
-;; program sbstract syntax tree 
-(defstruct prog_src)
-
-(defstruct (prog_if (:include prog_src)) 
-  cond_expr then_expr else_expr)
-
-(defstruct (prog_setq (:include prog_src))
-  setq_var setq_expr)
-
-(defstruct (prog_apply (:include prog_src))
-  appl_fun appl_args)
-
-(defstruct (prog_primitive (:include prog_src))
-  prim_oper prim_args)
-
-(defstruct (prog_chunk (:include prog_src)) ;chunks are used in primitive normalization
-  chunk_args chunk_type)
-
-(defstruct (prog_cstring (:include prog_src)) ;A C string constant
-   c_str)
-
-(defstruct (prog_quotesym (:include prog_src)) ;A quoted symbol or keyword
-   qsym)
-
-;;; the normalisation of a primitive requires its expansion as
-;;; primitive calls ans primitive chunks
-
-(defstruct (prog_let (:include prog_src))
-  let_bindings let_body)
-
-(defstruct (prog_send (:include prog_src))
-  send_sel send_recv send_args)		
-
-(defstruct (prog_unsafe_get_field (:include prog_src))
-  uget_field uget_obj)
-
-(defstruct (prog_unsafe_put_fields (:include prog_src))
-  uput_obj uput_keys)
-
-;; make an instance at runtime ; 
-(defstruct (prog_make_instance (:include prog_src))
-  mki_class mki_keys mki_classdef	;the classdef is internal, neede for normal forms
-)	
-
-(defstruct (prog_forever (:include prog_src))
-  forever_bind forever_body)
-
-(defstruct (prog_progn (:include prog_src))
-  progn_body)
-
-(defstruct (prog_exit (:include prog_src))
-  exit_bind exit_body)
-
-;internal representation of closed variable occurrence
-(defstruct (prog_closedvar (:include prog_src))
-  clv_var				;the closed variable
-  clv_fun				;the closing function or lambda
-  clv_bind				;the binding of the closed variable
-)
-			
-; internal representation of closure allocation and fill
-(defstruct (prog_makeclosure (:include prog_src))
-  mkclos_fun				; the normalized function or lambda
-  mkclos_closvars				; the list of closed variables
-)
-
-(defstruct (prog_def (:include prog_src)) 
-  def_name)
-
-(defstruct (prog_predef (:include prog_def))
-  predef_rank)
-
-
-;;prog_defun are for defun and for normalized anonymous lambda
-(defstruct (prog_defun (:include prog_def)) ;defined name
-  fun_lambda				    ;if this defun comes from a lambda otherwise nil
-  fun_formals 				;list of formal arguments
-  fun_body				;sequence of body
-  fun_argbindings			;computed argument bindings
-  fun_closvars				;computed closed variable list
-  fun_constants				;computed list of quoted constants
-)
-
-;; prog_lambda are for source lambda
-(defstruct (prog_lambda  (:include prog_src))
-  lambda_formals			;list of formal arguments
-  lambda_body 				;sequence for body
-  lambda_argbindings 			;computed arguments bindings
-  lambda_closvars			;computed closed variable list
-  lambda_uniq				;unique number
-)
-
-
-
-;; prog_multicall are for multiple-binding of secondary results of calls
-(defstruct (prog_multicall (:include prog_src))
-  multicall_formals			;formal list of result variables
-  multicall_call			;the call or send
-  multicall_body			;body
-)
-
-
-(defstruct (prog_defvar (:include prog_predef)) ;@!not yet implemented
-  var_expr)
-
-(defstruct (prog_defclass  (:include prog_predef)) 
-  class_super class_ownfields class_allfields)
-
-(defstruct (prog_definstance  (:include prog_predef)) 
-  inst_class inst_objnum inst_slots)
-
-(defstruct (prog_defselector  (:include prog_definstance)) 
-)
-
-
-
-(defstruct instance_slot
-  slot_field slot_value)
-
-(defstruct (prog_field (:include prog_def))
-  field_class field_offset)
-
-(defstruct (prog_return (:include prog_src))
-  retexprs)
-
-(defstruct (prog_defprimitive (:include prog_def))
-  primitive_formals primitive_type primitive_expansion)
-
-;; for each variable occurrence, we need to know if the variable is
-;; closed within the current function (or lambda) or bound inside
-
-(defstruct cold_compenv
-  serial		 ;serial number
-  dict 					;dictionnary of bindings (by name)
-  prev 					;link to previous environment
-  for 					;optional function for which this env is made
-)
-
-;; flag to set to revert to default compenv printing
-(defvar cold_compenv_defprint nil)
-
-;; variable counting the number of compenv printing
-(defvar count_compenv_print 0)
-
-;; internal function to compute an hashcode for the dict of an environment
-(defun envdicthash (env)
-  (let ( (h (cold_compenv-serial env)) )
-    (maphash (lambda (k v) 
-	       (setq h (logand #xFFFFFFFF (+ h (* 8 (sxhash k)) (sxhash v)))))
-	     (cold_compenv-dict env))
-    h
-))
-
-
-;; internal hashtable to avoid printing manytimes the same environ
-;; we map an environment to its envdicthash and its printing counter 
-(defvar envprintdict (make-hash-table :size 1000))
-
-;; for less verbose traces & debugs
-(defmethod  print-object ((ob cold_compenv) st)
-  (if cold_compenv_defprint 
-      (call-next-method ob st)
-    (progn
-      (incf  count_compenv_print)
-      (format st "CompEnv/~d<#~d>{~:@_"  (cold_compenv-serial ob) count_compenv_print)
-      (let ( (curenv ob) 
-	     (curdepth 0)
-	     )
-	(loop while curenv do
-	      (finish-output st)
-	      (let* ( (edict (cold_compenv-dict curenv))
-		      (edicthash (envdicthash curenv))
-		      (eprev (cold_compenv-prev curenv))
-		      (efor  (cold_compenv-for curenv)) 
-		      (eserial (cold_compenv-serial curenv))
-		      (epri (gethash curenv envprintdict))
-		      (eprihash (and epri (car epri)))
-		      (epricnt (and epri (cdr epri)))
-		      )
-		(if (and 
-		     (> curdepth 0) 
-		     (eq eprihash edicthash)
-		     (> epricnt (- count_compenv_print 64)))
-		    (format st "!!*seecompenv/~d <<^^h~x#~d>>~:@_" eserial edicthash epricnt)
-		  (let ( (newpri (cons edicthash count_compenv_print)) )
-		    (setf  (gethash curenv envprintdict) newpri)
-		    (format st "!compenv/~d [~d] <H~x>:~:@_"  
-			    eserial (hash-table-count edict) (envdicthash curenv))
-		    ;; display bindings in a sorted order
-		    (let ( (revkeylist nil) )
-		      (maphash (lambda (k v) 
-				 (declare (ignore v))
-				 (push k revkeylist)) edict)
-		      (mapcar 
-		       (lambda (k) (format st " *~a== ~S~:@_" k (gethash k edict)))
-		       (sort revkeylist (lambda (k1 k2) (string< (symbol-name k1) (symbol-name k2))))
-		       )
-		      )
-		    (if efor 
-			(cond ( (prog_defun-p efor)
-				(format st "!compenv/~d - for defun ~S~:@_" eserial (prog_defun-def_name efor)) )
-			      ( (prog_lambda-p efor)
-				(format st "compenv/~d - for lambda #~d~:@_" eserial (prog_lambda-lambda_uniq efor)) )
-			      ( t
-				(format st "compenv/~d - for? ~S~:_" eserial efor) ))
-		      )
-		    ))
-		(if eprev 
-		    (format st "!compenv/~d prev/~d: ~:@_" eserial (cold_compenv-serial eprev)))
-		(setq curenv eprev)
-		(incf curdepth)
-		)
-	      )
-	)
-      (format st "}~:@_")
-      (finish-output st)
-      )))
-  
-;; for less verbose traces & debugs
-(defmethod  print-object ((ob prog_primitive) st)
-  (let ( (poper (prog_primitive-prim_oper ob))
-	 (pargs (prog_primitive-prim_args ob)) )
-    (if (prog_defprimitive-p poper)
-	(format st "#{Primitive/~a ~<~S~>}" (prog_defprimitive-def_name poper) pargs)
-      (call-next-method ob st))))
-
-
-;; for less verbose 
-(defmethod print-object ((ob prog_closedvar) st)
-  (let ( (cvar (prog_closedvar-clv_var ob))
-	 (cfun (prog_closedvar-clv_fun ob))
-	 (cbind (prog_closedvar-clv_bind ob)) )
-  (format st "#{ProgClosedVar/~a" cvar)
-  (if (prog_defun-p cfun) 
-      (format st " cfun/~a" (prog_defun-def_name cfun))
-      (format st " cfun=~S" cfun))
-  (cond 
-   ( (cold_class_binding-p cbind)
-     (format st " cbind<class:~S>" (cold_class_binding-bname cbind)) )
-   ( t
-     (format st " cbind=~S" cbind)))
-  (format st "}")
-))
-;; for less verbose traces
-(defmethod print-object ((ob prog_defclass) st)
-  (let ( (cname (prog_defclass-def_name ob))
-	 (crank (prog_defclass-predef_rank ob))
-	 (csuper (prog_defclass-class_super ob))
-	 (cownf (prog_defclass-class_ownfields ob))
-	 (callf (prog_defclass-class_allfields ob)) )
-  (format st "#{ProgDefClass/~a" cname)
-  (if crank (format st " predefrank/~S" crank))
-  (if (prog_defclass-p csuper) 
-      (format st " super:~a" (prog_defclass-def_name csuper))
-    (format st " super=~S" csuper))
-  (if cownf (format st " ownfl=~S" cownf))
-  (if callf (format st " allfl=~S" callf))
-  (format st "}")
-))
-
-
-(defmethod print-object ((ob prog_field) st)
-  (let ( (fname (prog_field-def_name ob))
-	 (fclass (prog_field-field_class ob))
-	 (foff (prog_field-field_offset ob)) )
-    (format st "#{ProgField/~a#~d" fname foff)
-    (if (prog_defclass-p fclass)
-	(format st " FldClass/~a" (prog_defclass-def_name fclass))
-      (format st " FldClass=~S" fclass))
-    (format st "}")    
-    ))
-
-(defmethod print-object ((ob prog_return) st)
-  (let ( (re (prog_return-retexprs ob)) )
-    (cond ( (and (consp re) (cdr re))
-	    (progn
-	      (format st "#{ProgReturn~d" (length re))
-	      (mapc (lambda (x) (format st " ~S" x)) re)
-	      (format st "}")
-	      ))
-	  ( (null re) (format st "{ProgReturn0}"))
-	  ( t (format st "{Prog_RETURN ~S}" (car re))))
-    ))
-
-
-(defconstant cold_valid_types_list (list ':value ':long ':bool ':tree ':void  ':cstring	;and others
-				    ))
-
-;; test for valid cold type keyword
-(defun cold_valid_type_keyword_p (k) 
-  (member k cold_valid_types_list))
-
-
-(defvar cold_compenv_serial_count 0)
-
-(defconstant cold_first_env 
-  (progn 
-    (incf cold_compenv_serial_count) 
-    (make-cold_compenv :serial cold_compenv_serial_count)))
-
-(defun cold_fresh_env (parenv)
-  (if parenv (or (cold_compenv-p parenv) 
-		 (error "invalid parent env ~a ~%<::cold_fresh_env>" parenv)))
-  (incf cold_compenv_serial_count)
-  (make-cold_compenv :prev parenv 
-		     :dict (make-hash-table :size 11)
-		     :serial cold_compenv_serial_count))
-
-(defstruct cold_any_binding
-  bname)
-
-(defstruct (cold_macro_binding (:include cold_any_binding))
-  expanser)
-
-
-;; for less verbose traces & debugs
-(defmethod  print-object ((ob cold_macro_binding) st)
-  (format st "#<!cold_macro_binding ~A!>" (cold_macro_binding-bname ob))
-)
-
-(defstruct (cold_class_binding (:include cold_any_binding))
-  classdef 				;the prog_defclass
-  classdata				;the obj_datainstance
-)
-
-(defstruct (cold_field_binding (:include cold_any_binding))
-  fieldef				;the prog_field
-  fieldata				;the obj_datainstance
-)
-
-
-
-(defstruct (cold_primitive_binding  (:include cold_any_binding))
-  primitive
-)
-
-;; for less verbose traces & debugs
-(defmethod  print-object ((ob cold_primitive_binding) st)
-  (if (prog_defprimitive-p (cold_primitive_binding-primitive ob))
-      (format st "#<!cold_primitive_binding ~A!>" (cold_primitive_binding-bname ob))
-    (call-next-method ob st)
-))
-
-
-
-
-(defstruct (cold_function_binding  (:include cold_any_binding))
-  function
-  fclodata					;function closure data 
-)
-
-;; for less verbose traces & debugs
-(defmethod  print-object ((ob cold_function_binding) st)
-  (if (prog_defun-p (cold_function_binding-function ob))
-      (format st "#<!cold_function_binding ~A!>" (cold_function_binding-bname ob))
-    (call-next-method ob st)
-))
-
-(defstruct (cold_typed_binding (:include cold_any_binding))
-  type)
-
-(defstruct (cold_instance_binding (:include cold_typed_binding))
-  instancedef instancedata)
-
-(defstruct (cold_selector_binding (:include cold_typed_binding))
-  selectordef selectordata)
-
-(defstruct (cold_let_binding  (:include cold_typed_binding))
-  expr 
-)
-
-(defstruct (cold_value_binding  (:include cold_typed_binding))
-  val 
-  compilrole 				;optional compiler role, eg SELECTOR 
-)
-;;; maybe we need a cold_fieldvalue_binding which is a
-;;; cold_value_binding and also knows about the field at compile time
-;;; and likewise for classes and instances and selectors
-
-(defstruct (cold_code_binding  (:include cold_typed_binding))
-  code 
-)
-
-
-(defstruct (cold_formal_binding (:include cold_typed_binding))
-  rank 
-  )
-
-
-(defstruct (cold_cdata_binding (:include cold_typed_binding))
-  cdata)
-
-(defstruct (cold_forever_binding (:include cold_typed_binding))
-  uniq					;unique gensymed id
-)
-
-(defstruct (cold_obforever_binding (:include cold_forever_binding))
-  lobvar					;forever objvar
-)
-
-
-;; for ease of trace & debugging
-(defmethod print-object ((ob cold_let_binding) st)
-  (let ( (bna (cold_any_binding-bname ob))
-	 (bty (cold_typed_binding-type ob))
-	 (bex (cold_let_binding-expr ob)) )
-  (format st "{LetBi[~a" bna)
-  (if bty (format st " :~s" bty))
-  (format st " := ~S ]}" bex)
-))
-
-
-;; convert a keyword :AA to symbol AA
-(defun keyword2symbol (k) 
-  (if (keywordp k) (intern (symbol-name k)) k))
-
-
-;; function to find a binding
-(defun cold_find_binding (nam env)
-  (and (cold_compenv-p env)
-       (let ((dict (cold_compenv-dict env)))
-	 (or (and 
-	      (hash-table-p dict)
-	      (gethash nam dict))
-	     (cold_find_binding nam (cold_compenv-prev env))
-	 ))
-       ))
-
-;;; function to find a binding and also return the reversed list of enclosing functions
-(defun cold_enclosed_find_binding (nam env)
-  (labels (
-	   (recscan (nam env lifun)
-		    (and (cold_compenv-p env)
-			 (let ( (dict (cold_compenv-dict env))
-				(envprev  (cold_compenv-prev env))
-				(newlifun 
-				 (let ( (forf (cold_compenv-for env)) )
-				   (if forf (cons forf lifun) lifun))) )
-			   (if (hash-table-p dict)
-			       (let ( (bi (gethash nam dict)) )
-				 (if bi (values bi lifun)
-				   (recscan nam envprev newlifun)))
-			     (recscan nam envprev newlifun)
-			     ))))
-	   )
-    (recscan nam env ())))
-		    
-      
-
-
-(defun cold_tested_find_binding (nam env test)
-  (and (cold_compenv-p env)
-       (let ((dict (cold_compenv-dict env)))
-	 (or (and 
-	      (hash-table-p dict)
-	      (gethash nam dict))
-	     (and 
-	      (funcall test env)
-	      (cold_find_binding nam (cold_compenv-prev env))
-	 )))))
-
-	      
-  
-(defun cold_put_binding (cbind env)
-  (assert (cold_compenv-p env))
-  (or (cold_any_binding-p cbind)
-      (error "bad cold binding ~S to put in env ~S~%<::cold_put_binding>" cbind env))
-  (let ( (bnam (cold_any_binding-bname cbind))
-	 (dict (cold_compenv-dict env))) 
-    (or (hash-table-p dict) 
-	(progn 
-	  (setq dict (make-hash-table :size 13))
-	  (setf (cold_compenv-dict env) dict)
-	  ))
-    (setf (gethash bnam dict) cbind)
-    )
-)
-
-(defun cold_define_macro (nam expans env)
-  (let ( (mbind (make-cold_macro_binding 
-		 :bname nam :expanser expans)) )
-    (cold_put_binding mbind env))
-)
-
-
-(defun cold_macroexpand (sexpr env)
-  (flet 
-   ( (makeapply 
-      (f args)
-      (assert (not (keywordp f)) 
-	      (f sexpr) 
-	      "invalid fun f=~S to makeapply in macroexpand sexpr=~S" f sexpr)
-      (make-prog_apply :appl_fun f :appl_args args)) 
-     (makeprim 
-      (p args)
-      (make-prog_primitive :prim_oper p :prim_args args))
-     (expandlist
-      (l)
-      (mapcar (lambda (e) (cold_macroexpand e env)) l)
-      )
-     )
-   (if (consp sexpr)
-       (let ( (oper (first sexpr))
-	      (args (rest sexpr)) )
-	 (if (listp oper)
-	     (makeapply 
-	      ;; maybe this is too simple, what if the macroexapsnion
-	      ;; yields a slector...
-	      (cold_macroexpand oper env) (expandlist args))
-	   (let ( (obind (cold_find_binding oper env)) )
-	     (cond ((cold_macro_binding-p obind)
-		    (let ( (mexp (cold_macro_binding-expanser obind)) )
-		      (apply mexp (list oper args env))
-		      ))
-		   ((cold_primitive_binding-p obind)
-		    (makeprim (cold_primitive_binding-primitive obind)
-			      (expandlist args))
-		    )
-		   ((cold_field_binding-p obind)
-		    (error "field application not yet implemented ~S~%<::cold_macroexpand>" oper))
-		   ( (or (cold_selector_binding-p obind)
-			 (and (cold_value_binding-p obind)
-			      (eq (cold_value_binding-compilrole obind) 
-				  'SELECTOR)))
-		     (let ( (expargs (expandlist args)) )
-		       (if (null expargs) 
-			   (error "send requires a reciever argument but got none ~S~%<::cold_macroexpand>" oper))
-		     (make-prog_send
-		      :send_sel oper
-		      :send_recv (first expargs)
-		      :send_args (rest expargs)
-		      ))
-		    )
-		   (t (makeapply oper (expandlist args)))
-		   ))))
-     sexpr
-     )))
-
-(defun cold_list_macroexpand (l env)
-  (mapcar (lambda (e) (cold_macroexpand e env)) l))
-
-
-(defmacro defcoldmacro (nam formals &rest body) 
-  `(cold_define_macro ',nam (lambda ,formals ,@body)  cold_first_env)
-)
-
-(defun write_c_comment (outs coms)
-  (write-string "/**!" outs)
-  (let ((lencom (length coms)))
-    (loop 
-     for rk from 0 to (- lencom 2) do
-     (let ( (c (char coms rk)) 
-	    (nc (char coms (+ rk 1)))
-	    )
-       (case c 
-	     (#\/ (if (eq nc #\*) (write-string "/+" outs) (write-char #\/ outs)))
-	     (#\* (if (eq nc #\/) (write-string "*+" outs) (write-char #\* outs)))
-	     (otherwise (write-char c outs))
-	     ))
-     )
-    )
-  (write-string "!**/" outs)
-  (if (find #\Newline coms) (write-char #\Newline outs))
-)
-
-(defmacro format_c_comment (str fmtstr &rest args)
-  (let ((sy (gentemp "FORMATCCOMM_")))
-    `(let ( (,sy (format nil ,fmtstr ,@args)) )
-       (write_c_comment ,str ,sy)
-       )
-    )
-)
-
-(defun str2cstr (istr)
-  (assert (stringp istr))
-  (with-output-to-string
-    (s)
-    (write-char #\" s)
-    (map nil
-	 (lambda (c)
-	   (case c
-		  (#\\ (write-string "\\\\" s))
-		  (#\" (write-string "\\\"" s))
-		  (#\' (write-string "\\\'" s))
-		  (#\Newline (write-string "\\\n" s))
-		  (#\Tab (write-string "\\\t" s))
-		  (otherwise (if (standard-char-p c) 
-				 (write-char c s)
-			       (format s "\\x~2,'0x" (char-code c))))
-		 )
-	   )
-	 istr
-	 )		
-    (write-char #\" s)      
-    )
-  )
-
-(defun lambda_args_bindings (formals)
-  (let ( (argrk 0)
-	 (argtype :value) 
-	 (arglist formals)
-	 (revargbind nil)
-	 )
-    (loop
-     (if (null arglist) 
-	 (return (reverse revargbind)))
-     (let ( (curarg (car arglist))
-	    (restarglist (cdr arglist)) )
-       (setq arglist restarglist)
-       (cond 
-	( (keywordp curarg)
-	  (or (cold_valid_type_keyword_p curarg) 
-	      (error "invalid formal keyword ~a in formals list ~s ~% <::lambda_args_binding>"
-		     curarg formals))
-	  (setq argtype curarg)
-	  )
-	( (symbolp curarg)
-	  (let ( (abind (make-cold_formal_binding :bname curarg
-						  :rank argrk 
-						  :type argtype)) )
-	    (push abind revargbind)
-	    (setq argrk (1+ argrk))
-	    )
-	  )
-	( t (error "invalid formal (not a symbol or keyword) ~a in formals list ~s ~% <::lambda_args_binding>" curarg formals) )
-	)
-       ))))
-
-
-(defvar cold_delayed_task_revlist nil)
-
-(defun cold_delayed_do (msg taskfun)
-  (assert (stringp msg))
-  (or (functionp taskfun) 
-      (error "cold_delayed_do bad taskfun ~s of type ~s ~% <::cold_delayed_do>"
-	     taskfun (type-of taskfun)))
-  (push (cons msg taskfun) cold_delayed_task_revlist)
-)
-
-(defmacro cold_delay (msg &rest body)
-  `(cold_delayed_do ,msg (function (lambda () ,@body))))
-
-(defun cold_run_delayed_tasks (&optional msg)
-  (and msg (or (stringp msg) (error "bad msg in cold_run_delayed_tasks ~S" msg)))
-  (loop 
-    (if (null cold_delayed_task_revlist) (return))
-    (let ( (taskslist (reverse cold_delayed_task_revlist)) )
-      (setq cold_delayed_task_revlist nil)
-      (map nil (lambda (taskcons) 
-		 ; (warn "delay running task ~S~%" (car taskcons))
-		 (apply (cdr taskcons) ())) taskslist)
-      ))
-  )
-
-
-(defcoldmacro defprimitive (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind 
-   (primnam formals type &rest body) args
-   (or (cold_valid_type_keyword_p type) 
-       (error "bad type ~S in defprimitive ~S" type args))
-   (assert (every (lambda (x) (or (symbolp x) (numberp x) (stringp x) (not (prog_src-p x)))) body))
-   (let ( (prim
-	   (make-prog_defprimitive 
-	    :def_name primnam
-	    :primitive_formals (lambda_args_bindings formals)
-	    :primitive_type type 
-	    :primitive_expansion body)) )
-     (let ( (pbind (make-cold_primitive_binding
-		    :bname primnam :primitive prim)) )
-       (cold_put_binding pbind env))
-     prim
-     )
-   )
-  )
-
-;; a defun function should be expanded in an environment where the
-;; defined function is bound, hence we use cold_delay, and the body
-;; should be expaned with the formals bound
-(defcoldmacro defun (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind 
-   (funam formals &rest body) args
-   (let* ( 
-	  (argbindseq (lambda_args_bindings formals))
-	  (newenv 
-	   (let ( (nenv (cold_fresh_env env)) )
-	     (map nil 
-		  (lambda (abind)  (cold_put_binding abind nenv)) 
-		  argbindseq)
-	     nenv
-	     ))
-	  (fun
-	   (make-prog_defun 
-	    :def_name funam
-	    :fun_formals formals
-	    :fun_argbindings argbindseq
-	    )) 
-	  (fbind (make-cold_function_binding :bname funam :function fun
-					     :fclodata (make-obj_dataclosure
-							:comname funam)
-					     )) 
-	  )
-     (cold_put_binding fbind env)
-     (cold_delay
-      (format nil "expand defun ~S" funam)
-      (setf (prog_defun-fun_body fun)  
-	    (mapcar 
-	     (lambda (e) (cold_macroexpand e newenv))
-	     body)
-	    )
-      )
-     fun
-     )))
-
-
-
-;;; a class binding
-(defcoldmacro defclass (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind
-   (cname &key predef super fields) args
-   (assert (symbolp cname) (cname) "invalid class name ~S" cname)
-   (let* 
-       ( (pdefclass (make-prog_defclass :def_name cname :predef_rank predef)) 
-	 (clabind (make-cold_class_binding :bname cname :classdef pdefclass))
-	 (superclass 
-	  (and super
-	       ;;;; we really should consider macro expansion on super
-	       (or (symbolp super) (error "bas super ~S in defclass ~S" super args))
-	       (let ( (superbind (cold_find_binding super env)) )
-		 (or (cold_class_binding-p superbind) 
-		     (error "bad superbinding ~S in defclass ~S" superbind args))
-		 (cold_class_binding-classdef superbind))))
-	 (superallfields
-	  (and super
-	       (prog_defclass-class_allfields superclass)))
-	 (off (if super (length superallfields) 0))
-	 )
-     (cold_put_binding clabind env)
-     (setf (prog_defclass-class_super pdefclass) superclass)
-     (let ( (fieldseq 
-	     (mapcar 
-	      (lambda (f) 
-		(or (symbolp f) (error "bad field ~S in defclass ~S" f args))
-		(if (cold_find_binding f env) 
-		    (error "field ~S already bound in defclass ~S" f args))
-		(let* 
-		    ( (field (make-prog_field :def_name f :field_class pdefclass :field_offset off)) 
-		      (fieldbind (make-cold_field_binding :bname f :fieldef field)) )
-		  (incf off)
-		  (cold_put_binding fieldbind env)
-		  field))
-	      fields)) )
-       ;; copy-list just to avoid lots of circular ref in debug
-       (setf (prog_defclass-class_ownfields pdefclass) 
-	     (copy-list fieldseq))
-       (setf (prog_defclass-class_allfields pdefclass) 
-	     (copy-list (append superallfields fieldseq)))
-       pdefclass			;expansion result for defclass
-       )
-     )))
-       
-
-
-;;; common code to definstance and defselector
-(defun instancemakerfun (iname iclassname idata env msg makfun bindfun)
-  (let ( (revslots ())
-	 (iobjnum ())
-	 (ipredef ())
-	 (curdata idata) 
-	 (bindclass (cold_find_binding iclassname env))
-	 )
-    (or (symbolp iname) 
-	(error "~A: expecting name but got ~S" msg iname))
-    (or (cold_class_binding-p bindclass)
-	(error "~A: ~A bad classname ~A" msg iname iclassname))
-    (let ((iclass (cold_class_binding-classdef bindclass)))
-      (assert (prog_defclass-p iclass))
-      (loop while (consp curdata) do
-	    (or (rest curdata)
-		(error "~A: odd arg  ~A  ~S" msg iname idata))
-	    (let ((curk (first curdata))
-		  (cura (second curdata)) )
-	      (setq curdata (cddr curdata))
-	      (or (keywordp curk) 
-		  (error "~A: expecting slot keyword but got ~S  ~A ~S" msg curk iname idata))
-	      (cond ( (eq curk ':obj_num)
-		      (setq iobjnum (cold_macroexpand cura env)) )
-		    ( (eq curk ':predef)
-		      (setq ipredef (cold_macroexpand cura env)) )
-		    ( t
-		      (let ((fld (find-if 
-				  (lambda (f) (equal (string (prog_field-def_name f)) (string curk))) 
-				  (prog_defclass-class_allfields iclass)
-				  )))
-			(or fld (error "~A: unexpected field ~S in ~A ~S" msg curk iname idata))
-			(let ((slodef (make-instance_slot 
-				       :slot_field fld
-				       :slot_value 
-				       (cold_macroexpand cura env))))
-			  (push slodef revslots))
-			)))))
-      (let* ( 
-	     (nval
-	      (funcall makfun
-		       iname
-		       ipredef
-		       iclass
-		       iobjnum
-		       (reverse revslots)))
-	     (nbind (funcall bindfun iname nval))
-	     )
-	(cold_put_binding nbind env)
-	nval
-	))))
-
-;;; a class binding
-(defcoldmacro definstance (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind
-   (iname iclassname &rest idata) args
-   (instancemakerfun iname iclassname idata env "definstance coldmacro" 
-		     ;; make value function
-		     (lambda (iname ipredef iclass iobjnum islots)
-		       (make-prog_definstance :def_name iname
-					      :predef_rank ipredef
-					      :inst_class iclass
-					      :inst_objnum iobjnum
-					      :inst_slots islots))
-		     ;; make binding function
-		     (lambda (iname nval)
-		       (make-cold_instance_binding
-			:bname iname
-			:type ':value
-			:instancedef nval
-		       ))
-		     )))
-
-
-
-(defcoldmacro defselector (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind
-   (iname iclassname &rest idata) args
-   (instancemakerfun iname iclassname idata env "defselector coldmacro" 
-		     ;; make value function
-		     (lambda (iname ipredef iclass iobjnum islots)
-		       (make-prog_defselector :def_name iname
-					      :predef_rank ipredef
-					      :inst_class iclass
-					      :inst_objnum iobjnum
-					      :inst_slots islots))
-		     ;; make binding function
-		     (lambda (iname nval)
-		       (make-cold_selector_binding
-			:bname iname
-			:type ':value
-			:selectordef nval
-			))
-		     )))
-
-
-;; the body of a lambda should be macroexpanded with the formals bound
-(defvar lambda_counter 0)
-(defcoldmacro lambda (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind 
-   (formals &rest body) args
-   (let* ( 
-	  (argbindseq (lambda_args_bindings formals))
-	  (newenv 
-	   (let ( (nenv (cold_fresh_env env)) )
-	     (map nil 
-		  (lambda (abind)  (cold_put_binding abind nenv)) 
-		  argbindseq)
-	     nenv
-	     ))
-	  (newlamb
-	   (make-prog_lambda :lambda_formals formals
-			     :lambda_body 
-			     (mapcar 
-			      (lambda (e) (cold_macroexpand e newenv))
-			      body)
-			     :lambda_argbindings argbindseq
-			     :lambda_uniq (incf lambda_counter)
-			     :lambda_closvars nil))
-	  )
-     newlamb
-)))
-
-
-;; the forever syntax (FOREVER <label> [<type>] <body...>)
-(defcoldmacro forever (nam args env)
-  (declare (ignore nam))
-  (let ( (foreverlab (pop args))
-	 (forevertype :value)
-	 (foreverbody nil) 
-	 (newenv (cold_fresh_env env))
-	 ) 
-    (or (symbolp foreverlab) (error "bad forever label in forever ~S" args))
-    (if (cold_valid_type_keyword_p (first args))
-	(setq forevertype (pop args)))
-    (if (eq forevertype ':void) (error "forever type cannot be void in forever ~S" args))
-    (setq foreverbody args)
-    (let ( (foreverbind (make-cold_forever_binding 
-		      :bname foreverlab
-		      :type forevertype
-		      :uniq (gentemp "_FOREVER_"))) )
-      (cold_put_binding foreverbind newenv)
-      (make-prog_forever :forever_bind foreverbind 
-		      :forever_body (mapcar (lambda (c) (cold_macroexpand c newenv)) foreverbody))
-    )))
-
-;; the progn syntax (PROGN <body....>)
-(defcoldmacro progn (nam args env)
-  (declare (ignore nam))
-  (make-prog_progn 
-   :progn_body (mapcar  (lambda (c) (cold_macroexpand c env)) args))
-)
-
-;; the UNSAFE_GET_FIELD syntax (UNSAFE_GET_FIELD field objexpr)
-(defcoldmacro unsafe_get_field (nam args env)
-  (declare (ignore nam))
-  (let (
-	(iargs args)
-	(ifldnam (pop args))
-	(iobjexpr (pop args)) )
-    (if args (error "too many arguments to unsafe_get_field ~S" iargs))
-    (or (keywordp ifldnam) 
-	(error "first arg should be a keyword fieldname: unsafe_get_field ~S" iargs))
-    (make-prog_unsafe_get_field
-     :uget_field ifldnam
-     :uget_obj  (cold_macroexpand iobjexpr env)
-     )
-))
-
-;; the UNSAFE_PUT_FIELDS syntax (UNSAFE_PUT_FIELDS objexpr fld1name fld1expr ...)
-(defcoldmacro unsafe_put_fields (nam args env)
-  (declare (ignore nam))
-  (let (
-	(iargs args)
-	(iobjexpr (pop args)) 
-	(irevkeys nil)
-	)
-    (loop while (and (consp args) (second args)) do
-	  (let ( 
-		(curfldnam (pop args))
-		(curvalexpr (pop args))
-		)
-	    (or (keywordp curfldnam) 
-		(error "expecting keyword fieldname but got ~S in unsafe_put_fields ~S"
-		       curfldnam iargs))
-	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
-	  ))
-    (make-prog_unsafe_put_fields
-     :uput_obj iobjexpr
-     :uput_keys (reverse irevkeys)
-     )
-))
-
-
-;; the MAKE_INSTANCE syntax (MAKE_INSTANCE objexpr fld1name fld1expr ...)
-(defcoldmacro make_instance (nam args env)
-  (declare (ignore nam))
-  (let (
-	(iargs args)
-	(iclass (pop args)) 
-	(irevkeys nil)
-	)
-    (or (symbolp iclass) (error "make_instance need a class symbol ~S" iargs))
-    (loop while (and (consp args) (second args)) do
-	  (let ( 
-		(curfldnam (pop args))
-		(curvalexpr (pop args))
-		)
-	    (or (keywordp curfldnam) 
-		(error "expecting keyword fieldname but got ~S in make_instance ~S"
-		       curfldnam iargs))
-	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
-	  ))
-    (make-prog_make_instance
-     :mki_class (normalize_symbol iclass env)
-     :mki_classdef iclass
-     :mki_keys (reverse irevkeys)
-     )
-))
-
-;; the EXIT syntax (EXIT <label> [<expr>])
-(defcoldmacro exit (nam args env)
-  (declare (ignore nam))
-  (let ( (exitlab (pop args)) 
-	 (exitexprs args)
-	 )
-    (or (symbolp exitlab) 
-	(error "EXIT need a symbol label: ~S" args))
-    (flet ((testnoforenv (env) (null (cold_compenv-for env))))
-	  (let ( (exitbind (cold_tested_find_binding exitlab env (function testnoforenv))) )
-	    (if (null exitbind) 
-		(error "EXIT label ~S is not bound" exitlab))
-	    (or (cold_forever_binding-p exitbind)
-		(error "label EXIT label ~S not bound to forever ~S" exitlab exitbind))
-	    (make-prog_exit 
-	     :exit_bind exitbind
-	     :exit_body (mapcar (lambda (c) (cold_macroexpand c env)) exitexprs)
-	    )))))
-
-
-;; SETQ syntax
-(defcoldmacro setq (nam args env)
-  (declare (ignore nam))
-  (if (rest (rest args)) (error "SETQ with more than two args ~S" args))
-  (destructuring-bind 
-   (var expr) args
-   (or (symbolp var) (error "bad setq macro args ~S" args))
-   (make-prog_setq :setq_var var
-		   :setq_expr (cold_macroexpand expr env)
-   )))
-
-
-;;; QUOTE syntax (only for symbols or keywords)
-(defcoldmacro quote (nam args env)
-  (declare (ignore nam))
-  (if (rest args) (error "quote with more than one arg ~S" args))
-  (let ((qarg (first args)))
-    (or (symbolp qarg) (keywords qarg)
-	(error "quote a non-symbol ~S" qarg))
-    (make-prog_quotesym :qsym qarg)
-))
-
-;; IF syntax
-(defcoldmacro if (nam args env)
-  (declare (ignore nam))
-  (destructuring-bind 
-   (scond sthen &optional selse) args
-   (make-prog_if 
-    :cond_expr (cold_macroexpand scond env)
-    :then_expr (cold_macroexpand sthen env)
-    :else_expr (if selse (cold_macroexpand selse env)))))
-
-;;; COND pseudo syntax
-;;; (COND ( t1 a1_1 a1_2 ) ( t2 a2_1 )) is expansed into 
-;;;; (IF t1 (PROGN a1_1 a1_2) (IF t2 a2_1))
-(defcoldmacro cond (nam args env)
-  (declare (ignore nam))
-  (let ( (rescond nil) )
-    (loop 
-     for clause in (reverse args)
-     for rk from 1
-     do
-     ; (warn "COND clause ~#d == ~S~%" rk clause)
-     ;; special case for last (t ...) or (:else ...) clause
-     (if (and (<= rk 1) (member (first clause) '(t :else else)))
-	 (if (rest (rest clause))
-	     (setq rescond (make-prog_progn 
-			    :progn_body (mapcar  
-					 (lambda (i) (cold_macroexpand i env))
-					 (rest clause))))
-	   (setq rescond (cold_macroexpand (second clause) env)))
-       (let ( (lenclause (length clause)) )
-	 (case lenclause 
-	       ( 1 (let ( (cndexp (cold_macroexpand (first clause) env)) )
-		     (setq rescond (make-prog_if 
-				    :cond_expr cndexp 
-				    :then_expr cndexp 
-				    :else_expr rescond))))
-	       ( 0 )
-	       ( 2 (let ( (cndexp (cold_macroexpand (first clause) env))
-			  (thnexp (cold_macroexpand (second clause) env)) )
-		     (setq rescond (make-prog_if 
-				    :cond_expr cndexp 
-				    :then_expr thnexp 
-				    :else_expr rescond))))
-	       (otherwise 
-		(let ( (cndexp  (cold_macroexpand (first clause) env))
-		       (progexprs (mapcar (lambda (i) (cold_macroexpand i env)) (rest clause))) )
-		  (setq rescond (make-prog_if
-				 :cond_expr cndexp
-				 :then_expr (make-prog_progn :progn_body progexprs)
-				 :else_expr rescond))))
-	       )))
-    ; (warn "COND partial rescond #~d == ~S~%" rk rescond)
-     )
-   ; (warn "COND ~s expands to ~S ;;COND expansion~%" args rescond)
-    rescond
-    ))
-
-;;; AND pseudo syntax
-;;; (AND a1 a2) is expansed into (IF a1 a2)
-;;; (AND a1 a2 a3) is expansed into (IF a1 (IF a2 a3))
-(defcoldmacro and (nam args env)
-  (declare (ignore nam))
-  ;; reject (and) without arguments
-  (if (null args) (error "(and) without any arguments"))
-  (labels ( (expand (a)
-		    (if (null (rest a)) 
-			(first a)
-		      (let ( (a1 (first a)) )
-			    (make-prog_if
-			     :cond_expr a1
-			     :then_expr (expand (rest a))))))
-	    ) 
-	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) 
-  ))
-
-;;; OR pseudo syntax
-;;; (OR a1) is expanded as a1
-;;; (OR a1 a2) is expanded as (IF a1 a1 a2)
-;;; (OR a1 a2 a3) is expanded as (IF a1 a1 (IF a2 a2 a3))
-(defcoldmacro or (nam args env)
-  (declare (ignore nam))
-  ;; reject (or) without arguments
-  (if (null args) (error "(or) without any arguments"))
-  (labels ( (expand (a)
-		    (if (null (rest a)) (first a)
-		      (let ( (a1 (first a)) )
-			    (make-prog_if
-			     :cond_expr a1
-			     :then_expr a1
-			     :else_expr (expand (rest a)))))) )
-	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) )
-  )
-
-;; LET syntax
-(defcoldmacro let (nam args env)
-  (declare (ignore nam))
-  (let ( (srcbinds (first args))
-	 (srcbody (rest args)) )
-    (let ( (revbindseq nil) 
-	   (newenv (cold_fresh_env env))
-	   )
-      (flet ( (bindhandle
-	       (sbind)
-	       (or (consp sbind) (error "bad src binding ~S in let ~S" sbind args))
-	       (let ( (f (first sbind)) 
-		      (lensbind (length sbind))
-		      )
-		 (let ( (newbind		       
-			 (cond
-			  ( (and (eq lensbind 3) (keywordp f))
-			    (let ( (sy (second sbind))
-				   (ex (third sbind)) )
-			      (or (cold_valid_type_keyword_p f)
-				  (error "bad type keyword ~S in let ~S" f args))
-			      (or (symbolp sy)
-				  (error "non symbol ~S to bind  in let ~S" sy args))
-			      (let ( (expa (cold_macroexpand ex newenv)) )
-				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
-				(make-cold_let_binding :bname sy 
-						       :expr expa
-						       :type f)
-				)))
-			  ( (eq lensbind 2) 
-			    (let ( (sy (first sbind))
-				   (ex (second sbind)) )
-			      (or (symbolp sy)
-				  (error "non symbol ~S to bind  in let ~S" sy args))
-			      (let ( (expa (cold_macroexpand ex newenv)) )
-				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
-				(make-cold_let_binding :bname sy 
-						       :expr expa))))
-			  ( t (error "bad binding ~S in let ~S" sbind args) )
-			  )))
-		   (push newbind revbindseq)
-		   (cold_put_binding newbind newenv)
-		   ))))
-	    (mapc (function bindhandle) srcbinds)
-	    (let ( (res
-		    (make-prog_let
-		     :let_bindings (reverse revbindseq)
-		     :let_body (cold_list_macroexpand srcbody newenv)
-		     )) )
-	      res
-	      )))))
-
-
-;;; MULTICALL syntax
-(defcoldmacro multicall (nam args env)
-  (declare (ignore nam))
-  (if (< (length args) 3) (error "too few arguments to multicall ~S" args))
-  (let* (
-	 (arglist args)
-	 (muformalseq (pop args))
-	 (mucall (pop args))
-	 (mubody args) 
-	 (muformalist (lambda_args_bindings muformalseq))
-	 (mufirst (first muformalist))
-	 (xcall (cold_macroexpand mucall env))
-	 (newenv (cold_fresh_env env))
-	 )
-    (or (prog_apply-p xcall) (prog_send-p xcall)
-	(error "multicall not of ~S application or send ~S" xcall arglist))
-    (assert (cold_formal_binding-p mufirst))
-    (mapc (lambda (b) (cold_put_binding b newenv)) muformalist)
-    (or (eq (cold_typed_binding-type mufirst) ':value)
-	(error "first formal of multicall should be a :value in multicall ~S" 
-	       arglist))
-    (let ( (mc
-	    (make-prog_multicall
-	     :multicall_formals muformalist
-	     :multicall_call xcall
-	     :multicall_body  (mapcar (lambda (b) (cold_macroexpand b newenv)) mubody)) 
-	    ) )
-      mc
-      )))
-
-
-(defcoldmacro return (nam args env)
-  (declare (ignore nam))
-  (let ( (retpr
-	  (make-prog_return :retexprs (mapcar (lambda (b) (cold_macroexpand b env)) args))) )
-    ;(break "return macro retptr ~S~%" retpr)
-   retpr))
-
-
-(defgeneric bind_normal_code (cod env)
-  (:documentation "normalization of (any) Basilys code, gives binding+normal code")
-)
-
-
-(defgeneric normalize_toplev (def env)
-  (:documentation "normalize a toplev definition or code"))
-
-(defmethod bind_normal_code ((cod prog_src) env)
-  (declare (ignore env))
-  ;; some stuff are already normal, eg defprimitive or quotsym
-  (values nil cod)
-)
-
-
-; we frequently may need to make an optional let around something
-(defun cold_wrap_let (revbindings cod)
-  (assert (listp revbindings))
-  (if revbindings
-      (progn 
-	(assert (cold_let_binding-p (first revbindings)))
-	(make-prog_let 
-	 :let_bindings (reverse revbindings)
-	 :let_body cod))
-    cod
-    )
-  )
-
-; likewise, but needing a sequence
-(defun cold_wrap_letseq (revbindings cod)
-  (assert (listp revbindings))
-  (if revbindings
-      (progn 
-	(assert (cold_let_binding-p (first revbindings)))
-	(make-prog_let 
-	       :let_bindings (reverse revbindings)
-	       :let_body cod))
-    cod)
-  )
-
-;; likewise, producing a list
-(defun cold_wrap_letlist (revbindings cod)
-  (assert (listp revbindings))
-  (if revbindings
-      (progn 
-	(assert (cold_let_binding-p (first revbindings)))
-	(list (make-prog_let 
-	       :let_bindings (reverse revbindings)
-	       :let_body cod)))
-    (if (listp cod) cod (list cod))
-    ))
-  
-
-;;; executable toplev normalisation
-(defmethod normalize_toplev ((cod prog_src) env)
-  (multiple-value-bind
-      (rbind ncod)
-      (bind_normal_code cod env)
-      (assert (listp rbind))
-    (cold_wrap_let rbind ncod)
-))
-
-
-
-;;- ;; normalization of a symbol occurrence means seeking if the symbol is
-;;- ;; closed or not and returning a prog_closedvar when appropriate
-(defun normalize_symbol (symb env)
-  (or (symbolp symb)
-      (error "normalize_symbol bad symb ~s ~%... in env ~s~%" symb env))
-  (multiple-value-bind 
-      (bnd revlis)
-      (cold_enclosed_find_binding symb env)
-    (cond ( (null symb)
-	    symb			;nil is always nil
-	    )
-	  ( (cold_class_binding-p bnd)
-	    symb			;should make some progconst
-	    )
-	  ( (cold_instance_binding-p bnd)
-	    symb			;should make some progconst of it
-	    )
-	  ( (cold_selector_binding-p bnd)
-	    symb			;should make some progconst of it
-	    )
-	  ( (cold_function_binding-p bnd)
-	    symb			;should make some progconst of it
-	    )
-	  ( (cold_value_binding-p bnd)
-	    symb			;should make some progconst of it
-	    )
-	  ( (cold_field_binding-p bnd)
-	    symb			;should make some progconst of it
-	    )
-	  ( (null bnd)
-	    (error "normalize_symbol ~S unbound in env ~S <:::normalize_symbol unbound ~S in ~S~%"
-		   symb env symb (and (prog_defun-p normalized_defun) (prog_defun-def_name normalized_defun))))
-	  ( (null revlis) 
-	    symb)
-	  (t (progn
-	       ;; check that a closed symbol is indeed a value
-	       (and (cold_typed_binding-p bnd)
-		    (not (null (cold_typed_binding-type bnd)))
-		    (not (eq (cold_typed_binding-type bnd) ':value))
-		    (error "normalize_symbol ~S closed not value ~S" symb bnd))
-	;       (break "normalize_symbol symb ~S bnd ~S revlis ~S~%" symb bnd revlis)
-	       (let ( (clovs
-		       (mapcar 
-			(lambda (lr)
-			  (assert (prog_lambda-p lr) (lr bnd symb) "normalize_symbol symb=~S bnd=~S expect lr=~S to be a prog_lambda" symb bnd lr)
-			  (or 
-			   (find-if
-			    (lambda (cv)
-			      (assert (prog_closedvar-p cv))
-			      (eq (prog_closedvar-clv_var cv) symb))
-			    (prog_lambda-lambda_closvars lr))
-			   (let ( (ncv (make-prog_closedvar 
-					:clv_var symb 
-					:clv_fun lr
-					:clv_bind bnd)) )
-			     (push ncv (prog_lambda-lambda_closvars lr))
-			     ncv)))
-			revlis)) )
-		 (first clovs)
-		 ))))))
-
-
-
-;; we need to normalize a sequence, possibly adding new let_bindings
-;; to complex arguments this function returns two results: the
-;; normalized sequence and the reversed list of bindings the prefix is
-;; for gentemp-ing the variables; the revbindseq argument is the
-;; initial value of reversed list of bindings (usually nil)
-(defun normalize_code_sequence (seq env prefix  revbindseq)
-  (or (listp seq) 
-      (error "normalize_code_sequence bad seq ~s" seq))
-  (or (cold_compenv-p env) 
-      (error "normalize_code_sequence bad env ~s" env))
-  (or (stringp prefix)
-      (error "normalize_code_sequence bad prefix ~s" prefix))
-  (or (listp revbindseq) 
-      (error "normalize_code_sequence bad revbindseq ~s" revbindseq))
-  (flet (  (handlexpr 
-	    (exp) 
-	    (cond 
-	     ( (prog_src-p exp)
-	       (let ( (nsym (gentemp prefix)) )
-		 (multiple-value-bind
-		  (normrevbind normexp)
-		  (bind_normal_code exp env)
-		  (assert (listp normrevbind))
-		  (if (consp normexp) 
-		      (error "bad normexp ~S in normalize_code_sequence seq ~S exp ~S" normexp seq exp))
-		  (setq revbindseq (append normrevbind revbindseq))
-		  (let ( (newbind  
-			  (make-cold_let_binding :bname nsym :expr normexp)) )
-		    (if (prog_chunk-p normexp)
-			(setf (cold_typed_binding-type newbind)
-			      (prog_chunk-chunk_type normexp)))
-		    (push newbind
-			  revbindseq))
-		  nsym
-		  ) ))
-	     ( (symbolp exp)
-	       (normalize_symbol exp env) )
-	     ( t exp ))) 
-	   )
-	(values (mapcar (function handlexpr) seq) revbindseq)))
-
-
-(defmethod bind_normal_code ((cod null) env)
-  (declare (ignore env))
-  (values nil nil)
-)
-
-(defmethod bind_normal_code ((cod t) env)
-  (declare (ignore env))
-;  (warn "bind_normal_code t ~S env ~S" cod env)
-  (values nil cod)
-)
-
-(defmethod bind_normal_code ((cod symbol) env)
-  (values nil (normalize_symbol cod env)))
-
-
-(defmethod bind_normal_code ((cod prog_setq) env)
-  (let ( (va (prog_setq-setq_var cod))
-	 (ex (prog_setq-setq_expr cod)) )
-    (or (symbolp va) (error "prog_setq bad variable ~S~%"))
-    (let ((nva (normalize_symbol va env)))
-      (multiple-value-bind 
-       (nexs pbindseqrev)
-       (normalize_code_sequence (list ex) env "_SETQ_" nil)
-       (assert (null (rest nexs)))
-       (values nil
-	       (cold_wrap_let pbindseqrev
-			      (make-prog_setq 
-			       :setq_var nva
-			       :setq_expr (first nexs)
-			       )))))))
-
-
-(defun expand_primitive (srcod poper pargs)
-  (let* (
-	 (pformals (prog_defprimitive-primitive_formals poper))
-	 (pexpansion (prog_defprimitive-primitive_expansion poper))
-	 (pnbformals (length pformals))
-	 (htb (make-hash-table :size (+ (* 2 pnbformals) 3)))
-	 )
-    (if (/= pnbformals (length pargs))
-	(error "formals/args mismatch in primitive ~S" srcod))
-    ;; associate each formal with its actual argument in htb
-    (loop
-      for rk from 0
-      for curform in pformals
-      for curarg in pargs
-      do
-      (let ((curname (cold_any_binding-bname curform)))
-	(setf (gethash curname htb) curarg)
-	))
-    ;; make the expansion
-    (let ( (resexp 
-	    (mapcar 
-	     (lambda (e)
-	       (cond 
-		((numberp e) e)
-		((stringp e) e)
-		((symbolp e) 
-		 (multiple-value-bind 
-		     (symval symhere)
-		     (gethash e htb)
-		   (cond 
-		    ( (stringp symval) (make-prog_cstring :c_str symval)) 
-		    ( symhere symval )
-		    ( t 
-		      (warn "unbound symbol ~S in primitive poper ~S pargs ~S"
-			    e poper pargs)
-		      e ))
-		   ))
-		(t (error "bad element ~S in expansion of ~S" e poper))
-		))
-	     pexpansion))
-	   )
-      (make-prog_chunk :chunk_args resexp :chunk_type  (prog_defprimitive-primitive_type poper))
-      )
-    ))
-
-(defmethod bind_normal_code ((cod prog_primitive) env)
-  (let* ( (poper (prog_primitive-prim_oper cod))
-	  (pargs (prog_primitive-prim_args cod))
-	 )
-    (multiple-value-bind 
-	(normargs pbindseqrev)
-	(normalize_code_sequence pargs env "_PARG_" nil)
-      (values pbindseqrev
-	      (expand_primitive cod poper normargs))
-      )))
-
-
-
-
-(defmethod normalize_call ((cod prog_apply) env)
-  (let ( (afun (prog_apply-appl_fun cod))
-	 (aargs (prog_apply-appl_args cod)) 
-	 (abindseqrev nil) )
-    ;; normalize the applied function if needed
-    (cond  
-     ( (prog_src-p afun)
-       (multiple-value-bind
-	(frbind nfun)
-	(bind_normal_code afun env)
-	(assert (listp frbind))
-	(assert (prog_src-p nfun))
-	(let* (
-	       (fsym (gentemp "_AFUN_"))
-	       (fbind  (make-cold_let_binding
-			:bname fsym :expr nfun))
-	       )
-	  (setq abindseqrev (append frbind abindseqrev))
-	  (push fbind abindseqrev)
-	  (setq afun fsym))))
-     ( (symbolp afun)
-       (setq afun (normalize_symbol afun env)) )
-     ( t
-       (error "bad function to apply in ~s" cod))
-     )
-    ;; normalize the arguments
-    (multiple-value-bind 
-     (normargs pbindseqrev)
-     (normalize_code_sequence aargs env "_FARG_" abindseqrev)
-     (values 
-      (make-prog_apply 
-       :appl_fun afun
-       :appl_args normargs)
-      pbindseqrev
-      ))))
-
-(defmethod bind_normal_code ((cod prog_apply) env)
-  (multiple-value-bind
-      (cod bindrev)
-      (normalize_call cod env)
-    (values bindrev cod)
-  ))
-
-;;; normalize a let (gotten from source code)
-(defmethod bind_normal_code ((cod prog_let) env)
-  (let* ( (lbinds (prog_let-let_bindings cod))
-	  (lbody (prog_let-let_body cod)) 
-	  (newenv (cold_fresh_env env))
-	  (nbinds 
-	   (mapcar 
-	    (lambda (b) 
-	      (let ((nb (copy-cold_let_binding b)))
-		(multiple-value-bind
-		 (pbindrev pbody)
-		 (bind_normal_code (cold_let_binding-expr b) newenv)
-		 (assert (listp pbindrev))
-		 (setf (cold_let_binding-expr nb)
-		       (cold_wrap_let
-			pbindrev
-			pbody))
-		 (cold_put_binding nb newenv)
-		 nb)))
-	    lbinds))
-	  )
-    (multiple-value-bind 
-     (nbody pbindseqrev)
-     (normalize_code_sequence lbody newenv "_LETBODY_" nil)
-;;; since the new bindings are gensymed, no risk of conflict with old ones
-     (values
-      nil
-      (cold_wrap_letseq 
-       (append pbindseqrev (reverse nbinds))
-       nbody)
-      )
-     )))
-
-
-;; normalize an if
-(defmethod bind_normal_code ((cod prog_if) env)
-  (let* ( (icond (prog_if-cond_expr cod))
-	  (ithen (prog_if-then_expr cod))
-	  (ielse (prog_if-else_expr cod)) )
-    (multiple-value-bind 
-     (ncond condbindseqrev)
-     (normalize_code_sequence (list icond) env "_IFCOND_" nil) 
-     ;; if the condition has been gentemp-ed force its binding of type long
-     ;; if it had no type
-     (let ( (nc1 (first ncond)) )
-       (if (symbolp nc1)
-	   (let ( (bc1 (find-if (lambda (b) 
-				  (and (cold_let_binding-p b)
-				       (eq nc1 (cold_any_binding-bname b))))
-				condbindseqrev)) )
-	     (if (cold_typed_binding-p bc1) 
-		 (or (cold_typed_binding-type bc1)
-		     (setf  (cold_typed_binding-type bc1) :long))
-	       ))))
-     (multiple-value-bind
-      (thenrevbind normthen)
-      (bind_normal_code ithen env)
-      (assert (listp thenrevbind))
-      (values
-       condbindseqrev
-       (make-prog_if 
-	:cond_expr (first ncond)
-	:then_expr (cold_wrap_let thenrevbind normthen)
-	:else_expr 
-	(if ielse 
-	    (multiple-value-bind
-	     (elserevbind normelse)
-	     (bind_normal_code ielse env)
-	     (assert (listp elserevbind))
-	     (cold_wrap_let elserevbind normelse))
-	  )
-	))))))
-
-
-;; normalize a forever
-
-(defmethod bind_normal_code ((cod prog_forever) env)
-  (let* ( (ibind (prog_forever-forever_bind cod))
-	  (ibody (prog_forever-forever_body cod)) 
-	  (newenv (cold_fresh_env env)) 
-	  )
-    (cold_put_binding ibind newenv)
-    (multiple-value-bind 
-	(nbody bindseqrev)
-	(normalize_code_sequence ibody newenv "_FOREVERB_" nil)
-	(assert (listp bindseqrev))
-      (values
-       nil
-       (make-prog_forever
-	:forever_bind ibind
-	:forever_body 
-	(cold_wrap_letlist
-	 bindseqrev nbody
-	 ))))))
-    
-
-
-;; normalize an exit
-(defmethod bind_normal_code ((cod prog_exit) env)
-  (let* ( (ibind (prog_exit-exit_bind cod))
-	  (ibody (prog_exit-exit_body cod)) )
-    (multiple-value-bind 
-     (nbody bindseqrev)
-     (normalize_code_sequence ibody env "_EXIT_" nil) 
-     (assert (listp bindseqrev))
-     (values
-      bindseqrev
-      (make-prog_exit 
-       :exit_bind ibind
-       :exit_body nbody
-       )))))
-
-
-
-
-;; normalize a progn
-(defmethod bind_normal_code ((cod prog_progn) env)
-  (let ((ibody (prog_progn-progn_body cod)))
-    (values
-     nil
-     (make-prog_progn
-      :progn_body 
-      (mapcar 
-       (lambda (comp) 
-	 (multiple-value-bind 
-	  (sbind scod)
-	  (bind_normal_code comp env)
-	  (assert (listp sbind))
-	  (cold_wrap_let
-	   sbind scod)
-	  ))
-       ibody)))))
-       
-
-    
-;; normalize a multicall
-(defmethod bind_normal_code ((cod prog_multicall) env)
-  (let ( (iformals (prog_multicall-multicall_formals cod)) ;list of formal bindings
-	 (icall (prog_multicall-multicall_call cod))
-	 (ibody (prog_multicall-multicall_body cod)) 
-	 (newenv (cold_fresh_env env))
-	 )
-    (mapc (lambda (b) (cold_put_binding b newenv)) iformals)
-    (multiple-value-bind 
-     (normcall pcallbindseqrev)
-     ;;; we should normalize only the sequence of args of the call or send
-     ;;; it should stay a call or a send
-     (normalize_call icall env)
-     (assert (or (prog_send-p normcall) (prog_apply-p normcall)))
-     (assert (listp pcallbindseqrev))
-     (multiple-value-bind 
-      (normbody pbodybindseqrev)
-      (normalize_code_sequence ibody newenv "_MULCALLBODY_" nil)
-      (assert (listp pbodybindseqrev))
-      (values 
-       pcallbindseqrev
-       (make-prog_multicall
-	:multicall_formals iformals
-	:multicall_call normcall
-	:multicall_body 
-	(cold_wrap_letlist
-	 pbodybindseqrev normbody
-	 )))))))
-
-
-
-;; normalize a send
-(defmethod normalize_call ((cod prog_send) env)
-  (let ( (isel (prog_send-send_sel cod))
-	 (irecv (prog_send-send_recv cod))
-	 (iargs (prog_send-send_args cod)) )
-    (assert (symbolp isel))
-    (multiple-value-bind 
-     (normrecvargs pbindseqrev)
-     (normalize_code_sequence (cons irecv iargs) env "_SEND_" nil)
-     (let ( (nrecv (first normrecvargs))
-	    (nargs (rest normrecvargs)) 
-	    )
-       (values
-	(make-prog_send
-	 :send_sel (normalize_symbol isel env)
-	 :send_recv nrecv
-	 :send_args nargs)
-	pbindseqrev
-	)))))
-
-(defmethod bind_normal_code ((cod prog_send) env)
-  (multiple-value-bind
-   (nsend pbindseqrev)
-   (normalize_call cod env)
-   (assert (listp pbindseqrev))
-   (values pbindseqrev nsend)))
-
-;;; normalize an unsafe_get_field
-(defmethod bind_normal_code ((cod prog_unsafe_get_field) env)
-  (let ( (ifldname (prog_unsafe_get_field-uget_field cod))
-	 (iobjexpr (prog_unsafe_get_field-uget_obj cod)) )
-    (let ( (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
-      (assert (cold_field_binding-p ifldbind) (ifldbind) 
-	      "invalid fldbind ~S for fldname ~S in unsafe_get_field ~S env ~S <:::bad get_field ~S" 
-	      ifldbind ifldname cod env ifldname)
-      (let ( (fld (cold_field_binding-fieldef ifldbind)) )
-	(multiple-value-bind 
-	 (nobjbind nobjexpr)
-	 (bind_normal_code iobjexpr env)
-	 (assert (listp nobjbind))
-	 (values 
-	  nobjbind
-	  (make-prog_unsafe_get_field
-	   :uget_field fld
-	   :uget_obj nobjexpr)
-	  ))))))
-
-
-;;; normalize an unsafe_put_fields
-(defmethod bind_normal_code ((cod prog_unsafe_put_fields) env)
-  (let ( (iobjexpr (prog_unsafe_put_fields-uput_obj cod))
-	 (ikeys (prog_unsafe_put_fields-uput_keys cod)) 
-	 (nrevkeys nil)
-	 )
-    ;; check key symbols and make the list of fields
-    (let (
-	(fieldlist 
-	 (mapcar (lambda (kpair) 
-	    (let* ( (ifldname (car kpair))
-		    (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
-	      (assert (cold_field_binding-p ifldbind) (ifldbind) 
-		      "invalid fldbind ~S in unsafe_put_fields ~S fldname ~S env ~S" ifldbind cod ifldname env)
-	       (cold_field_binding-fieldef ifldbind)
-	      ))
-	  ikeys))
-	)
-    ;; normalize the object expression
-    (multiple-value-bind
-     (nobjbinds nobjexpr)
-     (bind_normal_code iobjexpr env)
-     ;;; normalize the field expressions
-     (multiple-value-bind
-      (nkeyexprs nkeybinds)
-      (normalize_code_sequence
-       (mapcar #'cdr ikeys)
-       env "_UPUTF_"  nobjbinds)
-      ;;; make the normalized key pairs
-      (mapc 
-       (lambda (fld nexpk)
-	 (push (cons fld nexpk) nrevkeys)
-	 ) fieldlist nkeyexprs)
-      (values
-       nkeybinds
-       (make-prog_unsafe_put_fields
-	:uput_obj nobjexpr
-	:uput_keys (reverse nrevkeys))
-       ))))))
-
-
-
-
-;;; normalize an make_instance
-(defmethod bind_normal_code ((cod prog_make_instance) env)
-  (let ( (iclass (prog_make_instance-mki_class cod))
-	 (ikeys (prog_make_instance-mki_keys cod)) 
-	 (nrevkeys nil)
-	 )
-    ;; check class & key symbols and make the list of fields
-    (let* (
-	   (classbind (cold_find_binding iclass env))
-	   (classdef (if (cold_class_binding-p classbind) 
-			 (cold_class_binding-classdef classbind)
-		       (error "make_instance ~S not a class bind ~S env ~S"
-			      iclass classbind env)))
-	   (fieldlist 
-	    (mapcar (lambda (kpair) 
-		      (let* ( (ifldname (car kpair))
-			      (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
-			(assert (cold_field_binding-p ifldbind) (ifldbind) 
-				"invalid fldbind ~S in make_instance ~S for fldname ~S env ~S<:: bad make_instance fieldname ~S~%"
-				ifldbind cod ifldname env ifldname)
-			(let* ( (fld (cold_field_binding-fieldef ifldbind)) 
-				(fldoff (prog_field-field_offset fld))
-				)
-			  (assert (eq (nth fldoff (prog_defclass-class_allfields classdef)) fld)
-				  (fld)
-				  "bad field ~S in make_instance ~S" fld cod)
-			  fld
-			  )
-			))
-		    ikeys))
-	   )
-;;; normalize the field expressions
-      (multiple-value-bind
-       (nkeyexprs nkeybinds)
-       (normalize_code_sequence
-	(mapcar #'cdr ikeys)
-	env "_UMKI_"  nil)
-;;; make the normalized key pairs
-       (mapc 
-	(lambda (fld nexpk)
-	  (push (cons fld nexpk) nrevkeys)
-	  ) fieldlist nkeyexprs)
-       (values
-	nkeybinds
-	(make-prog_make_instance
-	 :mki_class (normalize_symbol iclass env)
-	 :mki_classdef classdef
-	 :mki_keys (reverse nrevkeys))
-	)))))
-
-
-
-;; normalize the body of a lambda or a function
-;; hence put an implicit return on last element
-(defun normalize_body (body env)
-  (assert (cold_compenv-p env))
-  (or (listp body) (error "bad body ~S for normalize_body ~%" body))
-  (multiple-value-bind
-   (nseq nbind)
-   (normalize_code_sequence body env "_BODY_" nil)
-   (assert (listp nbind))
-   (if (listp nseq)
-       (let ( (bl (butlast nseq))
-	      (l  (last nseq)) )
-	 (if (prog_return-p (first l))
-	     (cold_wrap_letseq nbind nseq)
-	   (cold_wrap_letlist
-	    nbind 
-	    (append bl (list (make-prog_return :retexprs l)))
-	    )
-	   )))))
-
-
-
-;;;;;;; normalize a lambda
-(defmethod bind_normal_code ((cod prog_lambda) env)
-  (let* ( (formals (prog_lambda-lambda_formals cod))
-	  (body (prog_lambda-lambda_body cod))
-	  (argbs (prog_lambda-lambda_argbindings cod))
-	  (newenv (cold_fresh_env env))
-	  (ncod (copy-prog_lambda cod))
-	  )
-    (setf (cold_compenv-for newenv) ncod)
-    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
-    (let*( (nbody (normalize_body body newenv))
-	   (nfnam (gentemp "_LAMBDAFUN_"))
-	   (nclosv  (prog_lambda-lambda_closvars ncod))
-	   (nfun (make-prog_defun
-		  :def_name nfnam
-		  :fun_formals formals
-		  :fun_argbindings argbs
-		  :fun_body nbody
-		  :fun_lambda cod
-		  :fun_closvars nclosv))
-	   ;; call normalize_symbol on each closed variable in the lambda
-	   ;; with the side-effect of propagating, if necessary, the closed
-	   ;; variables into the current function
-	   (closvseq (mapcar (lambda (cv) 
-			       (normalize_symbol (prog_closedvar-clv_var cv) env)) 
-			     nclosv))
-	   )
-      (push nfun (compilation-functions this_compilation))
-      (setf (prog_lambda-lambda_body ncod) nbody)
-      (cold_delay
-       "addobjcode lambda"
-       (let ( (cofun (compile_obj nfun newenv)) ) 
-	 (add_objcode cofun)
-	 )
-       )
-      (let( (mkclos 
-	     (make-prog_makeclosure
-	      :mkclos_fun nfun
-	      :mkclos_closvars closvseq)) )
-	(values nil mkclos)
-	))))
-
-
-
-(defmethod bind_normal_code ((cod prog_return) env)
-  (let ( (retargs (prog_return-retexprs cod)) )
-    ;; normalize the arguments
-    (multiple-value-bind 
-     (normargs pbindseqrev)
-     (normalize_code_sequence retargs env "_RETARG_" ())
-     (values pbindseqrev
-	     (make-prog_return
-	      :retexprs normargs)
-	     ))))
-
-	  
-
-
-(defvar normalized_defun nil)
-  
-(defmethod normalize_toplev ((cod prog_defun) env)
-  (let* ( (ncod (copy-prog_defun cod)) 
-	  (fbody (prog_defun-fun_body cod))
-	  (argbs (prog_defun-fun_argbindings cod))
-	  (newenv (cold_fresh_env env))
-	  )
-    (setq normalized_defun cod)
-    (setf (cold_compenv-for newenv) ncod)
-    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
-    (let( (nbody (normalize_body fbody newenv)) )
-      (setf (prog_defun-fun_body ncod) nbody))
-    (setq normalized_defun ())
-    ncod
-    ))
-  
-
-
-(defmethod normalize_toplev ((cod prog_definstance) env)
-  (let* ( (ncod (copy-prog_definstance cod)) 
-	  (slots (prog_definstance-inst_slots cod))
-	  (nslots 
-	   (mapcar 
-	    (lambda (s) 
-	      (assert (instance_slot-p s))
-	      (make-instance_slot 
-	       :slot_field (instance_slot-slot_field s)
-	       :slot_value 
-	       (multiple-value-bind
-		   (sbind sexpr)
-		   (bind_normal_code 
-		    (instance_slot-slot_value s)
-		    env)
-		 (cold_wrap_let sbind sexpr))))
-	    slots)) )
-    (setf (prog_definstance-inst_slots ncod) nslots)
-    ncod)
-  )
-
-(defmethod normalize_toplev ((cod prog_defselector) env)
-  (let* ( (ncod (copy-prog_defselector cod)) 
-	  (slots (prog_defselector-inst_slots cod))
-	  (nslots 
-	   (mapcar 
-	    (lambda (s) 
-	      (assert (instance_slot-p s))
-	      (make-instance_slot 
-	       :slot_field (instance_slot-slot_field s)
-	       :slot_value 
-	       (multiple-value-bind
-		   (sbind sexpr)
-		   (bind_normal_code 
-		    (instance_slot-slot_value s)
-		    env)
-		 (cold_wrap_let sbind sexpr))))
-	    slots)) )
-    (setf (prog_defselector-inst_slots ncod) nslots)
-    ncod)
-  )
-
-;;;;;;;;;;;; compile to object
-(defstruct compilation
-  functions				;list of prog- functions
-  currout				;current routine
-  initrout				;initialization routine
-  revobjcode				;generated object code reversed list
-  cdata					;constructed data
-  symboldict				;dictonnary of gererated symbols
-)
-
-
-
-;; sometimes we need to take the length of a stuff and round it to 1 if it is empty
-(defun my_length_gt_1 (s) 
-  (let  ( (l (length s)) )
-    (if (> l 0) l 1)))
-
-(defstruct obj_instr
-)
-
-(defgeneric output_ccode (obj str)
-  (:documentation "output C code from Basilys code")
-)
-
-(defgeneric output_cdecl (obj str)
-  (:documentation "output C declaration from Basilys code")
-)
-
-(defmethod output_ccode ((obj t) str)
-  (error "invalid arg (type ~A) to output_ccode ~S" (type-of obj)  obj)
-)
-
-(defmethod output_ccode ((obj symbol) str)
-  (format str "/*@Symb*/((void*)(BASILYSG(~S)))" obj))
-
-(defmethod output_ccode ((obj null) str)
-  (format str "/*@Nil*/NULL"))
-
-(defmethod output_ccode ((obj string) str)
-  (format str "/*@String*/~S" obj))
-
-(defmethod output_ccode ((obj integer) str)
-  (format str "/*@Integer*/~S" obj))
-
-(defmethod output_cdecl ((obj t) str)
-  (error "unexpected output_cdecl (type ~A) ~S~%" (type-of obj) obj)
-  (format_c_comment str "**@declobj t![~A]~%~S~%**" (type-of obj) obj))
-
-(defstruct (obj_get_arguments (:include obj_instr))
-  instrs
-)
-
-(defstruct (obj_verbatim)
-  vstr)
-
-(defstruct (obj_verbatiminstr (:include obj_instr))
-  vstr)
-
-(defmethod  print-object ((ob obj_verbatim) st)
-  (let ((*print-circle* nil))
-  (format st "{ObVerb ~S}" (obj_verbatim-vstr ob))))
-
-(defmethod output_ccode ((obj obj_verbatim) str)
-  (write-string (obj_verbatim-vstr obj) str)
-)
-
-(defmethod  print-object ((ob obj_verbatiminstr) st)
-  (let ((*print-circle* nil))
-  (format st "{ObVerbIns ~S}" (obj_verbatiminstr-vstr ob))))
-
-(defmethod output_ccode ((obj obj_verbatiminstr) str)
-  (write-string (obj_verbatiminstr-vstr obj) str)
-)
-
-(defstruct (obj_cstring)
-  obcstr)
-
-(defmethod output_ccode ((obj obj_cstring) str)
-  (let ( (cstri (obj_cstring-obcstr obj)) 
-	 )
-    (format_c_comment str "obj_cstring ~S" cstri)
-    (write-string " \"" str)
-    (map nil 
-	 (lambda (c) 
-	   (case c
-		 (#\Newline (write-string "\\n" str))
-		 (#\Tab  (write-string "\\t" str))
-		 (#\\ (write-string "\\\\" str))
-		 (#\' (write-string "\\'" str))
-		 (#\" (write-string "\\\"" str))
-		 (otherwise (if (standard-char-p c)
-				(write-char c str)
-			      (format str "\\x~2,'0x" (char-code c))))
-		 )
-	   )
-	 cstri)
-    (write-string "\" " str)
-    ))
-
-
-(defmethod output_ccode ((obj prog_src) str)
-  (format_c_comment str "~%*** progsrc ~S ***~%~%" obj))
-
-(defgeneric query_ctype (obj)
-  (:documentation "query type of C code")
-)
-
-(defmethod query_ctype ((obj t))
-nil)
-
-(defgeneric put_destination (obj dest)
-  (:documentation "set the destination of C code from Basilys code & return nil or a new objectocde")
-)
-
-(defgeneric get_destination (obj)
-  (:documentation "retrieve the destination of C code from Basilys code")
-)
-
-(defmethod put_destination ((obj t) dest)
-;  (warn "default put_destination obj ~S dest ~S" obj dest)
-  (if (prog_src-p obj) (error "put_destination prog_src obj ~S" obj))
-  (build_obj_compute
-   dest
-   (list obj)
-   (query_ctype obj))
-)
-
-(defmethod put_destination ((obj integer) dest)
-  (build_obj_compute
-   dest
-   (list obj)
-   :long)
-)
-
-(defmethod put_destination ((obj string) dest)
-  (error "put_destination stringobj ~S dest ~S" obj dest)
-  (build_obj_compute
-   dest
-  (list obj)
-  nil)
-)
-
-(defmethod get_destination ((obj t))
-  nil					;do nothing by default
-)
-
-(defmethod output_ccode ((obj cons) str)
-  (format str "/*@list ~d*/ " (length obj))
-  (mapc (lambda (o) 
-	  (format str "~%")
-	  (output_ccode o str)) 
-	obj)
-  (format str "/*@endlist ~d*/ " (length obj)))
-
-(defmethod output_ccode ((obj obj_get_arguments) str)
-  (let (( instrs (obj_get_arguments-instrs obj)))
-    (format str "/*obj_get_arguments ~d*/~%" (length instrs))
-    (mapc (lambda (i) (format str "~%") (output_ccode i str)) instrs)
-    (format str " goto lab_endargs;~%")
-    (format str "lab_endargs: ;~%")
-    )
-)
-
-
-(defstruct  (obj_clearptr (:include obj_instr))
-  clrptrvar
-)
-
-(defmethod output_ccode ((obj obj_clearptr) str)
-  (format str "/*clearptr*/ ")
-  (output_ccode (obj_clearptr-clrptrvar obj) str)
-  (format str " = NULL;~%")
-)
-
-(defstruct  (obj_clearlong (:include obj_instr))
-  clrlongvar
-)
-
-(defmethod output_ccode ((obj obj_clearlong) str)
-  (format str "/*clearlong*/ ")
-  (output_ccode (obj_clearlong-clrlongvar obj) str)
-  (format str " = 0L;~%")
-)
-
-
-(defstruct (obj_data)
-  discr					;the discriminant
-  comname				;comment name
-  )
-
-
-;; add a data to the constdata pool of the compilation; so append the
-;; data to cdata, create a cdata binding for it an a pointerobjvar for
-;; it in the initial routine
-(defun add_cdata (da &optional why)
-  (assert (listp  (compilation-cdata this_compilation)))
-  (and (listp da) (error "bad list cdata ~S" da))
-  (assert (obj_data-p da) (da) "bad cdata ~S" da)
-  (assert (not (member da (compilation-cdata this_compilation))))
-  (push da (compilation-cdata this_compilation))
-  (assert (listp  (compilation-cdata this_compilation)))
-  (let* ( (nbdata (length  (compilation-cdata this_compilation)))
-	  (initrout (compilation-initrout this_compilation))
-	  (dbind  (make-cold_cdata_binding 
-			   :bname (gentemp "CDATA_")
-			   :type :value
-			   :cdata da)) 
-	  (ovar (newobjptrvar initrout dbind 
-			   (if why 
-			       (concatenate 'string "addCdata " (string why))
-			     "added cdata"))) )  
-    (setf (gethash da (obj_initroutine-inirou_datarankdict initrout)) nbdata)
-    (routine_link_data2ptr initrout da ovar)
-    )
-  ;; (format *error-output* "add_cdata da ~S~%" da)
-  da
-  )
-
-(defun add_objcode (ob)
-  (assert (listp  (compilation-revobjcode this_compilation)))
-  (assert (obj_routine-p ob) (ob) "adding bad objcode ~S" ob)
-  (push ob (compilation-revobjcode this_compilation))
-  (assert (listp  (compilation-revobjcode this_compilation)))
-  nil
-)
-
-;(defun put_progdata (pro &optional datagetfun)
-;  (assert (prog_src-p pro) (pro) "put bad progdata ~S" pro)
-;  (or  (gethash pro (compilation-progdict this_compilation))
-;       (if datagetfun
-;	   (let ((data (apply datagetfun (list pro))))
-;	     (assert (obj_data-p data) (data) "bad computed data ~S for progdata ~S" data pro)
-;	     (setf (gethash pro  (compilation-progdict this_compilation))
-;		   data)
-;	     (or (currout_data2ptr data) (add_cdata data))
-;	     data
-;	     ))))
-;
-;(defun progdata (pro)
-; (gethash pro (compilation-progdict this_compilation)))
-;
-;(defun checked_progdata (pro)
-;  (or  (gethash pro (compilation-progdict this_compilation))
-;       (error "prog without data ~S" pro)))
-;
-
-(defmethod output_ccode ((obj obj_data) str)
-  (format str " /*-*ccode objdata ~S */ " (obj_data-comname obj))
-  (let ( (optr (currout_data2ptr obj)) )
-    (assert optr (obj optr) "output_ccode data ~S without ptr" obj)
-    (output_ccode optr str))
-;  (finish-output str)
-)
-
-(defgeneric output_cassign (obda str)
-  (:documentation "output the code to assign the data"))
-
-(defgeneric output_cinit (obda str)
-  (:documentation "output the code to initialize the data"))
-
-(defgeneric output_cfill (obda str)
-  (:documentation "output the code to fill the initialized data"))
-
-(defgeneric output_cverify (obda str)
-  (:documentation "output the code to verify the initialized data"))
-
-(defgeneric output_cref (obda str)
-  (:documentation "output the code to reference the data"))
-
-(defmethod output_cassign ((obda obj_data) str)
-  (let ( (cmsg (with-output-to-string 
-		(s) 
-		(format s "cassign/data cleared ~S #~d [~S]"
-			(obj_data-comname obda) (initrout_rank obda) (type-of obda)))) )
-    (format str "basilys_assertmsg(~a, NULL=="
-	    (str2cstr cmsg)))
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ");~%")
-  (format str "/*cassign data ~S #~d [~S] */~%"
-	  (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (output_ccode (currout_data2ptr obda) str)
-  (format str " = (void*) (&cdat->inidat_~d_);~%" (initrout_rank obda))
-  (format str "#if COLD_BASILYS_DEBUG~%")
-  (format str " debugeprintf(\" %s %p @%d\", ")
-  (write-string 
-   (str2cstr 
-    (with-output-to-string (s)
-			   (format s "cassign data ~S #~d [~S]"
-				     (obj_data-comname obda) 
-				     (initrout_rank obda) 
-				     (type-of obda))))
-   str)
-  (format str ", (void*) (&cdat->inidat_~d_), " (initrout_rank obda))
-  (format str " (int)offsetof(cdata_t, inidat_~d_));~%"  (initrout_rank obda))
-  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
-  )
-
-
-(defmethod output_cinit ((obda obj_data) str)	
-  (finish-output str)
-  (error "cannot output_cinit objdata ~S~%" obda)
-)
-
-
-(defmethod output_cfill ((obda obj_data) str)	
-  (finish-output str)
-  (error "cannot output_cfill objdata ~S~%" obda)
-)
-
-
-
-(defmethod output_cref ((obda obj_data) str)		
-  (format str " /*cref ~S [~S] #~d*/" (obj_data-comname obda) (type-of obda) (initrout_rank obda))
-  (format str " ((void*) (&cdat->inidat_~d_)) " (initrout_rank obda))
-;  (finish-output str)
-)
-
-(defstruct (obj_dataclosure (:include obj_data))
-  rout					;the routine
-  clodata				;closed data
-  )
-
-(defmethod output_ccode ((obj obj_dataclosure) str)
-  (format str " /*-*ccode objdataclosure ~S:*/ " (obj_data-comname obj))
-  (output_ccode (currout_data2ptr obj) str)
-;  (finish-output str)
-)
-
-(defmethod output_cverify ((obda obj_dataclosure) str)	
-;  (finish-output str)
-  (format str "/*cverify dataclosure ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (format str "basilys_assertmsg(\"cverify dataclosure ~S #~d\", basilys_magic_discr((" 
-	  (obj_data-comname obda) (initrout_rank obda))
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ")) == OBMAG_CLOSURE);~%")
-)
-
-(defmethod  print-object ((ob obj_dataclosure) st)
-  (let ( (obcna (obj_data-comname ob))
-	 (dis (obj_data-discr ob))
-	 (rou (obj_dataclosure-rout ob))
-	 (cld (obj_dataclosure-clodata ob)) )
-    (if (obj_routine-p rou)
-	(format st "#{ObjDataClosure ~S discr=~S rout/~a clodata=~S}"
-		obcna dis (prog_defun-def_name (obj_routine-pfun rou)) cld)
-      (call-next-method ob st)
-	  ))
-)
-
-(defstruct (obj_dataroutine (:include obj_data))
-  rout					;the routine
-  roudata				;routine data (reversed order), ie quoted constants
-)
-
-
-
-(defmethod print-object ((ob obj_dataroutine) st)
-  (let ( (obcna (obj_data-comname ob))
-	 (pvar (currout_data2ptr ob))
-	 (dis (obj_data-discr ob))
-	 (rou (obj_dataroutine-rout ob))
-	 (rd (obj_dataroutine-roudata ob)) )
-    (if (obj_routine-p rou)
-	(format st "#{ObjDataRoutine ~S ptrva=~S discr=~S rout/~a roudata*~d=~S}"
-		obcna pvar dis (prog_defun-def_name (obj_routine-pfun rou)) (length rd) rd)
-      (call-next-method ob st)
-	  ))
-)
-
-
-(defmethod output_ccode ((obj obj_dataroutine) str)
-  (format str " /*-*ccode objdataroutine ~S:*/ " (obj_data-comname obj))
-  (output_ccode (currout_data2ptr obj) str)
-;  (finish-output str)
-)
-
-(defmethod output_cverify ((obda obj_dataroutine) str)	
-;  (finish-output str)
-  (format str "/*cverify dataroutine ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (format str "basilys_assertmsg(\"cverify dataroutine ~S #~d\", basilys_magic_discr(("
-	  (obj_data-comname obda) (initrout_rank obda))
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ")) == OBMAG_ROUTINE);~%")
-)
-
-(defstruct (obj_datainstance (:include obj_data))
-  predef				;name of predefined rank or nil
-  objnum				;number (maybe magic) in instance
-  slots					;list of slot values
-)
-
-(defmethod  print-object ((ob obj_datainstance) st)
-  (let ( (obcna (obj_data-comname ob))
-	 (obdiscr (obj_data-discr ob))
-	 (obpredef (obj_datainstance-predef ob))
-	 (obnum (obj_datainstance-objnum ob))
-	 (obslots (obj_datainstance-slots ob)) )
-    (if (obj_datainstance-p obdiscr)
-	(progn
-	  (format st "#{ObjDataInst ~S Discr:~S" obcna (obj_data-comname obdiscr))
-	  (if obpredef (format st " Predef:~S" obpredef))
-	  (if obnum (format st " ObjNum:~S" obnum))
-	  (if obslots (format st " Slots:~S" obslots))
-	  )
-      (call-next-method ob st)
-      )))
-
-(defmethod output_ccode ((obj obj_datainstance) str)
-  (format str " /*-*ccode objdatainstance ~S :*/ " (obj_data-comname obj))
-  (let ( (op (currout_data2ptr obj)) )
-    (or op (error "output_ccode obj datainst ~S without data2ptr" obj))
-    (output_ccode op str)
-;    (finish-output str)
-    ))
-
-(defmethod output_cverify ((obda obj_datainstance) str)	
-;  (finish-output str)
-  (format str "/*cverify datainstance ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (format str "basilys_assertmsg(\"cverify  datainstance ~S #~d\", basilys_magic_discr(("
-	  (obj_data-comname obda) (initrout_rank obda))
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ")) == OBMAG_OBJECT);~%")
-)
-
-(defstruct (obj_datamultiple (:include obj_data))
-  values
-)
-
-(defstruct (obj_datastring (:include obj_data))
-  string
-)
-
-(defstruct (obj_dataqsymbol (:include obj_data))
-  qsymb)
-
-(defstruct (obj_dataqkeyword (:include obj_data))
-  qkeyword)
-	
-;;;;;; quoted symbol data
-(defmethod output_cdecl ((obj obj_dataqsymbol) str)
-  (format str "/*cdecl dataqsymbol ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-  (format str "char* iniqsymb_~d;~%"  (initrout_rank obj))
-  )
-	   
-(defmethod output_cassign ((obj obj_dataqsymbol) str)
-  (format str "/*cassign dataqsymbol ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-  (output_ccode (currout_data2ptr obj) str)
-  (format str " = basilysgc_new_symbol(~a);~%" (str2cstr (string (obj_dataqsymbol-qsymb obj))))
-  (format str "#if COLD_BASILYS_DEBUG~%")
-  (format str " debugeprintf(\" quoted symbol ~S @%p\","  (obj_dataqsymbol-qsymb obj))
-  (output_ccode (currout_data2ptr obj) str)
-  (format str ");~%")
-  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
-)	   
-
-(defmethod output_cinit ((obj obj_dataqsymbol) str)
-  (format str "/*cinit dataqsymbol ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-  (format str " cdat->iniqsymb_~d = ~a;~%"  (initrout_rank obj) 
-	  (str2cstr  (string (obj_dataqsymbol-qsymb obj))))
-)
-
-(defmethod output_cfill ((obj obj_dataqsymbol) str)
-  (format str "/*no cfill dataqsymbol ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-)
-
-(defmethod output_cref ((obj obj_dataqsymbol) str)
-  (format str "/*no cref dataqsymbol ~S #~d [~S] - '~S*/~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-)
-
-(defmethod output_cverify ((obj obj_dataqsymbol) str)
-  (format str "/*no cverify dataqsymbol ~S #~d [~S] - '~S*/~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
-)
-
-
-
-;;;;;;;; quoted keyword data		     
-(defmethod output_cdecl ((obj obj_dataqkeyword) str)
-  (format str "/*cdecl dataqkeyword ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-  (format str "char* iniqkey_~d;~%"  (initrout_rank obj))
-  )
-	   
-(defmethod output_cassign ((obj obj_dataqkeyword) str)
-  (format str "/*cassign dataqkeyword ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-  (output_ccode (currout_data2ptr obj) str)
-  (format str " = basilysgc_new_keyword(~a);~%" (str2cstr (string (obj_dataqkeyword-qkeyword obj))))
-  (format str "#if COLD_BASILYS_DEBUG~%")
-  (format str " debugeprintf(\" quoted keyword ~S @%p\"," (obj_dataqkeyword-qkeyword obj))
-  (output_ccode (currout_data2ptr obj) str)
-  (format str ");~%")
-  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
-)	   
-
-(defmethod output_cinit ((obj obj_dataqkeyword) str)
-  (format str "/*cinit dataqkeyword ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-  (format str " cdat->iniqkey_~d = ~a;~%"  (initrout_rank obj) 
-	  (str2cstr  (string (obj_dataqkeyword-qkeyword obj))))
-)
-
-(defmethod output_cfill ((obj obj_dataqkeyword) str)
-  (format str "/*no cfill dataqkeyword ~S #~d [~S] - '~S */~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-)
-
-(defmethod output_cref ((obj obj_dataqkeyword) str)
-  (format str "/*no cref dataqkeyword ~S #~d [~S] - '~S*/~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-)
-
-(defmethod output_cverify ((obj obj_dataqkeyword) str)
-  (format str "/*no cverify dataqkeyword ~S #~d [~S] - '~S*/~%"
-	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
-)
-
-;;;;;;;;;;;;;;;
-
-
-(defmethod output_cdecl ((obj obj_dataclosure) str)
-  (format str "/*- decl dataclosure ~S -*/~%" (obj_data-comname obj))
-  (format str " struct BASILYS_CLOSURE_STRUCT(~d) inidat_~d_;~%" 
-	  (my_length_gt_1 (obj_dataclosure-clodata obj)) (initrout_rank obj))
-)
-
-
-(defmethod output_cinit ((obj obj_dataclosure) str)
-    (format str "/*- init dataclosure ~S-*/~%" (obj_data-comname obj))
-    (let ( (irk (initrout_rank obj)) )
-      (assert (integerp irk))
-      (format str " cdat->inidat_~d_.discr = " irk)
-      (output_ccode (obj_data-discr obj) str) 
-      (format str ";~%")
-      (format str " cdat->inidat_~d_.rout = " irk)
-      (output_cref (obj_routine-datarout (obj_dataclosure-rout obj)) str)
-      (format str ";~%")
-      (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataclosure-clodata obj)))
-))
-
-
-(defmethod output_cfill ((obj obj_dataclosure) str)
-  (let ( (ov  (currout_data2ptr obj))
-	 )
-    (format str "/*- cfill dataclosure ~S -*/~%" (obj_data-comname obj))
-    (format str " basilys_assertmsg(\"cfill dataclosure ~S\", basilys_magic_discr((" (obj_data-comname obj))
-    (output_ccode ov str)
-    (format str ")) == OBMAG_CLOSURE);~%")
-    (let ( (nbd  (length  (obj_dataclosure-clodata obj))) )
-      (if (> nbd 0) 
-	  (progn
-	    (format str " basilys_assertmsg(\"cfill len dataclosure ~S\", ((basilysclosure_ptr_t)("
-		    (obj_data-comname obj))
-	    (output_ccode ov str)
-	    (format str "))->nbval >= ~d);~%" nbd))))
-    (loop
-     for crk from 0
-     for cda in (obj_dataclosure-clodata obj)
-     do
-     (format str " ((basilysclosure_ptr_t)(")
-     (output_ccode ov str)
-     (format str "))->tabval[~d] = " crk)
-     (output_ccode cda str)
-     (format str ";~%")
-     )
-     (format str " basilysgc_touch(")
-     (output_ccode ov str)
-     (format str ");~%")     
-  ))
-
-(defmethod output_cdecl ((obj obj_dataroutine) str)
-    (let ( (irk (initrout_rank obj)) )
-  (format str "/*- decl dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
-      (format str " struct BASILYS_ROUTINE_STRUCT(~d) inidat_~d_;~%" 
-	      (my_length_gt_1 (obj_dataroutine-roudata obj)) irk)
-  ))
-
-(defmethod output_cinit ((obj obj_dataroutine) str)
-  (let ( (irk (initrout_rank obj)) )
-    (format str "/*- init dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
-    (format str " cdat->inidat_~d_.discr = " irk)
-    (output_ccode (obj_data-discr obj) str) 
-    (format str ";~%")
-    (format str " strncpy(cdat->inidat_~d_.routdescr, \"~S\", BASILYS_ROUTDESCR_LEN-1);~%" 
- 	    irk (prog_defun-def_name (obj_routine-pfun (obj_dataroutine-rout obj))))
-    (format str " *(basilysroutfun_t **)(cdat->inidat_~d_.routaddr) = ~a;~%"
-	    irk (routinecname (obj_dataroutine-rout obj)))
-    (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataroutine-roudata obj)))
-    ))
-  
-
-(defmethod output_cfill ((obj obj_dataroutine) str)
-  (let (
-	(op (currout_data2ptr obj))
-	(irk (initrout_rank obj))
-	)
-    (format str "/*-cfill dataroutine ~S #~d -*/~%" (obj_data-comname obj) irk)
-    (format str " basilys_assertmsg(\"cfill dataroutine ~S #~d\", basilys_magic_discr((" (obj_data-comname obj) irk)
-    (output_ccode op str)
-    (format str ")) == OBMAG_ROUTINE);~%")
-    (let ( (nbd  (length (obj_dataroutine-roudata obj))) )
-      (if (> nbd 0) 
-	  (progn 
-	    (format str " gcc_assert(((basilysroutine_ptr_t)(")
-	    (output_ccode op str)
-	    (format str "))->nbval >= ~d);~%" nbd))))
-    (loop
-     for crk from 0
-     for cda in (reverse (obj_dataroutine-roudata obj))
-     do
-     (format str "((basilysroutine_ptr_t)(")
-     (output_ccode op str)
-     (format str "))->tabval[~d] = " crk)
-     (output_ccode cda str)
-     (format str ";~%")
-     )
-    (format str " basilysgc_touch(")
-    (output_ccode op str)
-    (format str ");~%")
-;    (finish-output str)
-    ))
-
-(defmethod output_cdecl ((obj obj_datainstance) str)
-  (let ( (irk (initrout_rank obj)) )
-  (format str "/*- decl datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
-  (format str " struct BASILYS_OBJECT_STRUCT(~d) inidat_~d_;~%" 
-	  (my_length_gt_1 (obj_datainstance-slots obj)) irk)
-;  (finish-output str)
-))
-
-
-(defmethod output_cinit ((obj obj_datainstance) str)
-  (let ( (irk (initrout_rank obj)) )
-    (format str "/*- init datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
-   (format str " cdat->inidat_~d_.obj_class = " irk)
-   (output_ccode (obj_data-discr obj) str) 
-   (format str ";~%")
-   (format str " cdat->inidat_~d_.obj_len = ~d;~%" irk (length (obj_datainstance-slots obj)));
-   (format str " cdat->inidat_~d_.obj_vartab =  cdat->inidat_~d_.obj__tabfields; ~%" irk irk)
-   ;; 134217728 is 2**27 so the hash is >0
-   (format str " cdat->inidat_~d_.obj_hash = ~d;~%" irk (+ 1 (random 134217728)))
-   (let ((onu (obj_datainstance-objnum obj)))
-     (if onu 
-	  (format str " cdat->inidat_~d_.obj_num = ~S;~%" irk onu)
-	)))
-    )
-
-(defmethod output_cassign ((obda obj_datainstance) str)
-  (let ( (irk (initrout_rank obda)) )
-    (format str "/*cassign datainstance ~S #~d*/" (obj_data-comname obda) irk)
-    (format str "basilys_assertmsg(\"cassign datainstance ~S #~d cleared\", NULL=="
-	    (obj_data-comname obda) irk)
-    (output_ccode (currout_data2ptr obda) str)
-    (format str ");~%")
-    (let ((prd (obj_datainstance-predef obda)))
-      (cond (( null prd) )
-	    ((symbolp prd) (format str "/*predef sym*/BASILYSG(~S) = " prd))
-	    ((integerp prd) (format str "/*predef num*/basilys_globarr[~d] = " prd))
-	    (t  (error "bad predef ~S in obj_datainstance ~S" prd obda)))
-      )
-    (output_ccode (currout_data2ptr obda) str)
-    (format str " = (void*) (&cdat->inidat_~d_);~%" irk)
-;    (finish-output str)
-    ))
-
-(defmethod output_cfill  ((obda obj_datainstance) str)
-  (let ( (sl  (obj_datainstance-slots obda))
-	 (ov  (currout_data2ptr obda))
-	 (irk (initrout_rank obda)) 
-	 )
-    (format str "/*cfill datainstance ~S #~d */~%" (obj_data-comname obda) irk)
-    (format str " basilys_assertmsg(\"cfill datainstance ~S #~d\", basilys_magic_discr((" 
-	    (obj_data-comname obda) irk)
-    (output_ccode ov str)
-    (format str " )) == OBMAG_OBJECT);~%")
-    (format str " basilys_assertmsg(\"cfill len datainstance ~S #~d\",  ((basilysobject_ptr_t)("
-	    (obj_data-comname obda) irk)
-    (output_ccode ov str)
-    (format str "))->obj_len >= ~d);~%" (length sl))
-;    (finish-output str)
-    (if sl
-	(loop
-	 for crk from 0
-	 for csl in sl
-	 when csl		       ;don't bother filling nil slots
-	 do
-;	 (finish-output str)
-	 ;; this is a dirty hack, csl should have cold_tempslot_var as
-	 ;; destination but some make-obj_datainstance don't do it.
-	 ;; if I wanted to code properly I would correct the callers.
-	 (or  (get_destination csl) 
-	      (let ((ncsl (put_destination csl cold_tempslot_var)))
-		(assert ncsl)
-		(setq csl ncsl)))
-	 (assert (eq (get_destination csl) cold_tempslot_var))
-	 (output_ccode csl str)
-	 (format str ";~%")
-	 (format str "basilys_checked_assign(((basilysobject_ptr_t)(")
-	 (output_ccode ov str)
-	 (format str ")) ->obj_vartab[~d] = " crk)
-	 (output_ccode cold_tempslot_var str)
-	 (format str ");~%")
-	 ))
-    (format str " basilysgc_touch(")
-    (output_ccode ov str)
-    (format str ");~%")
-;    (finish-output str)
-    ))
-
-(defmethod output_cdecl ((obj obj_datamultiple) str)
-  (let ( (irk (initrout_rank obj)) )
-  (format str "/*- decl datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
-  (format str " struct BASILYS_MULTIPLE_STRUCT(~d) inidat_~d_;~%" 
-	  (my_length_gt_1 (obj_datamultiple-values obj)) irk)
-  ))
-
-(defmethod output_cinit ((obj obj_datamultiple) str)
-  (let ( (irk (initrout_rank obj)) )
-  (format str "/*- init datamultiple ~S #~d-*/~%" (obj_data-comname obj) irk)
-   (format str " cdat->inidat_~d_.discr = " irk)
-   (output_ccode (obj_data-discr obj) str) 
-   (format str ";~%")
-   (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_datamultiple-values obj)))
-))
-
-(defmethod output_cfill ((obj obj_datamultiple) str)
-  (let ( (op (currout_data2ptr obj))
-	 (irk (initrout_rank obj))  )
-    (format str "/*- fill datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
-    (format str " gcc_assert(basilys_magic_discr((")
-    (output_ccode op str)
-    (format str ")) == OBMAG_MULTIPLE);~%")
-    (let ( (nbd  (length  (obj_datamultiple-values obj))) )
-      (if (> nbd 0)
-	  (progn
-	    (format str " gcc_assert(((basilysmultiple_ptr_t)(")
-	    (output_ccode op str)
-	    (format str "))->nbval >= ~d);~%" nbd))))
-;    (finish-output str)
-    (loop
-     for crk from 0
-     for cda in (obj_datamultiple-values obj)
-     do
-     (format str "((basilysmultiple_ptr_t)(")
-     (output_ccode op str)
-     (format str "))->tabval[~d] = " crk)
-     (output_ccode cda str)
-     (format str ";~%")
-     )
-     (format str " basilysgc_touch(")
-     (output_ccode op str)
-     (format str ");~%")
-;    (finish-output str)
-    ))
-
-(defmethod output_cverify ((obda obj_datamultiple) str)	
-;  (finish-output str)
-  (format str "/*cverify datamultiple ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (format str "gcc_assert(basilys_magic_discr((")
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ")) == OBMAG_MULTIPLE);~%")
-)
-
-(defmethod output_cdecl ((obj obj_datastring) str)
-;  (finish-output str)
-  (let ( (irk (initrout_rank obj))  )
-    (format str "/*- decl datastring ~S #~d -*/~%" (obj_data-comname obj) irk)
-    (format str " struct BASILYS_STRING_STRUCT(~d) inidat_~d_;~%" 
-      (my_length_gt_1 (obj_datastring-string obj)) irk)
-))
-
-
-(defmethod output_cinit ((obj obj_datastring) str)
-;  (finish-output str)
-  (let ( (irk (initrout_rank obj))  )
-    (format str "/*- init datastring ~S #~d-*/~%" (obj_data-comname obj) irk)
-    (format str " cdat->inidat_~d_.discr = " irk)
-    (output_ccode (obj_data-discr obj) str) 
-    (format str ";~%")
-    (format str " strcpy(cdat->inidat_~d_.val, ~s);~%" irk (obj_datastring-string obj))
-;    (finish-output str)
-    ))
-
-(defmethod output_cfill ((obj obj_datastring) str)
-  (finish-output str)
-)
-
-(defmethod output_cverify ((obda obj_datastring) str)	
-;  (finish-output str)
-  (format str "/*cverify datastring ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
-  (format str "gcc_assert(basilys_magic_discr((")
-  (output_ccode (currout_data2ptr obda) str)
-  (format str ")) == OBMAG_STRING);~%")
-)
-
-(defstruct (obj_getptrarg_instr (:include obj_instr))
-  dest
-  rk
-)
-
-(defmethod output_ccode ((obj obj_getptrarg_instr) str)
-  (format str "/*-*obj_getptrarg_instr*/~%")
-  (let ( (dest (obj_getptrarg_instr-dest obj))
-	 (rk  (obj_getptrarg_instr-rk obj)) )
-    (if (= rk 0) 
-	(progn 
-	  (format str "basilys_checked_assign(/*ptrarg0*/")
-	  (output_ccode dest str)
-	  (format str " = firstargp_);")
-	  )
-      (progn 
-	(format str "if (xargdescr_[~d] == BPAR_PTR)~% " (- rk 1))
-	(format str "basilys_checked_assign(/*ptrarg~d*/" rk)
-	(output_ccode dest str)
-	(format str
-		" = (xargtab_[~d].bp_aptr)?(*(xargtab_[~d].bp_aptr)):NULL);~% else goto lab_endargs;~%"
-		(- rk 1) (- rk 1))
-	(format str " gcc_assert(basilys_discr(")
-	(output_ccode dest str)
-	(format str ")!=NULL);~%")
-	)
-      )
-;    (finish-output str)
-    ))
-
-(defstruct (obj_getlongarg_instr (:include obj_instr))
-  dest
-  rk
-)
-
-(defmethod output_ccode ((obj obj_getlongarg_instr) str)
-  (format_c_comment str "*obj_getlongarg_instr ~S*~%" obj)
-  (let ( (dest (obj_getlongarg_instr-dest obj))
-	 (rk  (obj_getlongarg_instr-rk obj)) )
-    (if (= rk 0) 
-	(error "long arg cannot be first ~S" obj))
-    (format str "if (xargdescr_[~d] == BPAR_LONG)~% " (- rk 1))
-    (output_ccode dest str)
-    (format str " = xargtab_[~d].bp_long;~% else goto lab_endargs;~%"
-	    (- rk 1))
-;    (finish-output str)
-    )
-  )
-
-
-(defstruct (obj_getcstringarg_instr (:include obj_instr))
-  dest
-  rk
-)
-
-(defmethod output_ccode ((obj obj_getcstringarg_instr) str)
-  (format_c_comment str "*obj_getcstringarg_instr ~S*~%" obj)
-  (let ( (dest (obj_getcstringarg_instr-dest obj))
-	 (rk  (obj_getcstringarg_instr-rk obj)) )
-    (if (= rk 0) 
-	(error "long arg cannot be first ~S" obj))
-    (format str "if (xargdescr_[~d] == BPAR_CSTRING)~% " (- rk 1))
-    (output_ccode dest str)
-    (format str " = xargtab_[~d].bp_cstring;~% else goto lab_endargs;~%"
-	    (- rk 1))
-;    (finish-output str)
-    )
-  )
-
-
-;;; actually an obj_compute may have several destination (for example
-;;; for a setq whose value is used)
-    
-(defstruct (obj_compute (:include obj_instr))
-  dest				      ;last destination
-  sons					;either strings or expr or atoms
-  otype					;type
-  compserial				;unique serial number
-  )
-
-(defvar compute_serial_count 0)
-
-(defun build_obj_compute (dest sons otype)
-  (assert (listp sons))
-  (if (some (function prog_src-p) sons) 
-      (error "build_obj_compute bad sons {prog_src} ~S" sons))
-  (if (some (function obj_instr-p) sons) 
-      (error "build_obj_compute bad sons {obj_instr} ~S" sons))
-  (incf compute_serial_count)
-  (make-obj_compute :dest dest 
-		    :sons (if dest (append (list dest " = ") sons) sons) 
-		    :otype otype :compserial compute_serial_count)
-)
-
-
-;;; set a closed variable
-(defstruct (obj_closetq (:include obj_instr))
-  cldest				;closed destination
-  val)
-
-;;; obj_vars are variables (eg pointers, longs...) in the current stack frame
-(defstruct obj_var
-  vbind					;the binding defing the program variable
-  voffset				;the offset or index in the C frame
-  vrout					;the routine containing the variable
-  vwhy					;the reason why this stuff has been made
-  vfree					;set when freed in the curframe
-);; obj_ptrvar & obj_longvar are actually the relevant subclasses see
-;; also obj_closedvar (for variables in closures), obj_routconst (for
-;; constants inside routines), obj_initdata (for data in the initialization routine)
-
-(defmethod output_ccode ((obj obj_var) str)
-  (error "output_ccode obj_var ~s" obj)
-)
-
-(defmethod put_destination ((obj obj_var) dest)
-  (build_obj_compute
-   dest
-   (list obj)
-   (cond ((obj_ptrvar-p obj) :value)
-	 ((obj_longvar-p obj) :long)
-	 (t (error "put_destination obj strangevar ~S dest ~S" obj dest)))
-   ))
-
-
-(defmethod output_ccode ((obj obj_compute) str)
-  (format str "/* obj_compute.#~d */~%" (obj_compute-compserial obj))
-  (let ( (dest (obj_compute-dest obj)) )
-   (cond ((null dest)
-	  (format str " (void) ("))
-	 ((obj_ptrvar-p dest) (format str "basilys_checked_assign(/*comput*/")))
-    (mapc (lambda (s) (cond 		;order matters here!
-		       ( (stringp s) (format str "~a" s) )
-		       ( (integerp s) (format str "~d" s) )
-		       ( (null s) (format str "/*coputenil*/NULL") )
-		       ( (symbolp s)
-			 (format str "(/*compute symb*/BASILYSG(~S))" s) )
-		       ( (or (obj_instr-p s) (obj_var-p s) (obj_data-p s)
-			     (obj_closedvar-p s) 
-			     (obj_routconst-p s) (obj_verbatim-p s)
-			     (obj_cstring-p s)
-			     )		;before the atom test!
-			 (output_ccode s str) )
-		       ( (atom s) 
-			 (format str "(/*compute son [~S]*/~s)" (type-of s) s) )
-		       ( t (error "output_ccode obj_compute ~s !!invalid son ~s" obj s))))
-	  (obj_compute-sons obj))
-    (cond  ((null dest)
-	    (format str ");~%"))
-	   ((obj_ptrvar-p dest) (format str ");~%"))
-	   ((obj_longvar-p dest) (format str ";~%"))
-	   )
-    ))
-
-
-(defmethod put_destination ((obj obj_compute) dest)
-  (let ( (otyp (obj_compute-otype obj)) 
-	 (destyp  (query_ctype dest))
-	 )
-    (cond  (  (eq ':void otyp)
-	      (let ( (nblo (make-obj_block :instrs (list obj (make-obj_verbatim :vstr "/*Void*/NULL")))) )
-		(put_destination nblo dest))
-	      )
-	   (
-	    (or (null otyp) (null destyp) (eq otyp destyp))
-	    (setf (obj_compute-sons obj) (append (list dest " = ") (obj_compute-sons obj)))
-	    (setf (obj_compute-dest obj) dest)
-	    nil)
-	   (t 
-	    (make-obj_block :instrs 
-			    (list 
-			     obj
-			     (make-obj_verbatiminstr :vstr (format nil "/*incompatible put_destination dest ~S otyp ~S*/" dest otyp))
-			     (build_obj_compute
-			      dest
-			      (case otyp 
-				(:long (list (make-obj_verbatim :vstr "/*incompatput:long*/0L")))
-				(:value (list (make-obj_verbatim :vstr "/*incompatput:value*/(void*)0")))
-				(otherwise (list (make-obj_verbatim :vstr (format nil "/*incompatput- ~S */0" otyp))))
-				)
-			      otyp
-			      )
-			     ))))))
-
-(defmethod get_destination ((obj obj_compute))
-   (obj_compute-dest obj)
-)
-
-(defstruct (obj_ptrvar (:include obj_var)))
-
-(defstruct (obj_longvar (:include obj_var)))
-
-(defstruct (obj_cstringvar (:include obj_var)))
-
-(defmethod  print-object ((ov obj_ptrvar) st)
-  (if (cold_any_binding-p (obj_ptrvar-vbind ov))
-      (format st "ObjPtrVar@~d/~S?~S" 
-	      (obj_ptrvar-voffset ov) 
-	      (cold_any_binding-bname (obj_ptrvar-vbind ov))
-	      (obj_ptrvar-vwhy ov)
-	      )
-      (call-next-method ov st)
-))
-
-(defmethod  print-object ((ov obj_longvar) st)
-  (if (cold_any_binding-p (obj_longvar-vbind ov))
-      (format st "ObjLongVar@~d/~S?~S" 
-	      (obj_longvar-voffset ov) 
-	      (cold_any_binding-bname (obj_longvar-vbind ov))
-	      (obj_longvar-vwhy ov)
-	      )
-      (call-next-method ov st)
-      ))
-
-
-(defmethod  print-object ((ov obj_cstringvar) st)
-  (if (cold_any_binding-p (obj_cstringvar-vbind ov))
-      (format st "ObjCstringVar@~d/~S?~S" 
-	      (obj_cstringvar-voffset ov) 
-	      (cold_any_binding-bname (obj_cstringvar-vbind ov))
-	      (obj_cstringvar-vwhy ov)
-	      )
-      (call-next-method ov st)
-      ))
-
-
-(defconstant cold_return_var
-  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_RETVAL_ :type :value) 
-		   :voffset 0))
-
-(defconstant cold_tempslot_var
-  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_TMPSLOT_ :type :value) 
-		   :voffset 1))
-
-(defconstant cold_tempnum_var
-  (make-obj_longvar :vbind (make-cold_typed_binding :bname '_TMPNUM_ :type :long) 
-		   :voffset 0))
-
-
-(defmethod output_ccode ((obj obj_ptrvar) str)
-  (let ((b (obj_var-vbind obj))
-	(o (obj_var-voffset obj)))
-    (if b (format str "/*~S ? ~S*/" (cold_any_binding-bname b)
-		  (obj_var-vwhy obj)
-		  )
-      (format str "/*??~S*/" (obj_var-vwhy obj)))
-    (format str "curfptr[~d]" o)
-    )
-)
-
-(defmethod query_ctype ((obj obj_ptrvar))
-':value)
-
-
-
-(defmethod output_ccode ((obj obj_cstringvar) str)
-  (let ((b (obj_var-vbind obj))
-	(o (obj_var-voffset obj)))
-    (if b (format str "/*~S ? ~S*/" (cold_any_binding-bname b)
-		  (obj_var-vwhy obj)
-		  )
-      (format str "/*??~S*/" (obj_var-vwhy obj)))
-    (format str "curfram__.varcstring[~d]" o)
-    )
-)
-
-(defmethod query_ctype ((obj obj_cstringvar))
-':cstring)
-
-(defmethod query_ctype ((obj string))
-':cstring)
-
-
-
-(defmethod query_ctype ((obj obj_compute))
-  (obj_compute-otype obj))
-
-(defmethod output_ccode ((obj obj_longvar) str)
-  (let ((b (obj_var-vbind obj))
-	(o (obj_var-voffset obj)))
-    (if b (format str "/*~S ? ~S*/" 
-		  (cold_any_binding-bname b)
-		  (obj_var-vwhy obj)
-		  )
-      (format str "/*??~S*/" (obj_var-vwhy obj)))
-    (format str "curfnum[~d]" o)
-    )
-  )
-
-
-(defmethod output_ccode ((obj obj_closetq) str)
-  (let ((d (obj_closetq-cldest obj))
-	(s (obj_closetq-val obj)))
-    (or (obj_closedvar-p d) 
-	(error "not closedvar in obj_closetq ~S~%" obj))
-    (format str "/*closetq*/ {~% void* d = ")
-    (output_ccode d str)
-    (format str " = ")
-    (output_ccode s str)
-    (format str ";~%")
-    (format str "basilysgc_touch_dest(curfclos, d); }~%")
-))
-
-(defmethod query_ctype ((obj obj_longvar))
-':long)
-
-(defmethod query_ctype ((obj integer))
-':long)
-
-(defstruct obj_closedvar
-  cvar					;the name of the closed variable
-  cfun					;the function of the closure
-  coffset				;the offset inside the closure
-)
-
-(defmethod put_destination ((obj obj_closedvar) dest)
-  (build_obj_compute
-   dest
-   (list obj)
-   :value
-   ))
-
-(defmethod output_ccode ((obj obj_closedvar) str)
-  (format str "/*clovar ~s*/ curfclos->tabval[~d]" 
-	  (obj_closedvar-cvar obj) (obj_closedvar-coffset obj))
-)
-
-(defstruct obj_routconst
-  krout					;the routine quoting this constant
-  kval					;the value of the constant
-  koffset 				;the offset inside the function
-  kwhy					;string why
-)
-
-
-(defun newobjconst (val &optional why)
-  (let 
-      ( (curout (compilation-currout this_compilation) )
-	)
-    (assert (obj_data-p val) (val) "non-data values for newobjconst ~S" val)
-    (if (and (obj_routine-p curout) (not (obj_initroutine-p curout)))
-	;; usual case, we are in some routine
-	(let 
-	    ( (datarout (obj_routine-datarout curout)) )
-	  (or (obj_dataroutine-p datarout) 
-	      (error "newobjconst bad datarout ~S in curout ~S~%" datarout curout))
-	  (let ( (off (position val (obj_dataroutine-roudata datarout)))
-		 (ln (length (obj_dataroutine-roudata datarout))) )
-	    (if off 
-		(progn
-		  ;;(warn "newobjconst val=~S found off=~S ln=~S~%" val off ln)
-		  (make-obj_routconst :krout curout 
-				       :kval val 
-				       :koffset (- ln off 1)
-				       :kwhy why
-				       )
-		  )
-	      (let ( (ln (length (obj_dataroutine-roudata datarout))) )
-		(push val (obj_dataroutine-roudata datarout))
-		(let ( (newconst (make-obj_routconst :krout curout :kval val :koffset ln :kwhy why)) )
-		  newconst
-		  )
-		))))
-      ;; otherwise it is a global data 
-      (progn
-	(if  (null (currout_data2ptr val)) 
-	    (add_cdata val (concatenate 'string "newobjconst-" (string why)))
-	  val)
-	)
-      )))
-
-
-(defmethod output_ccode ((obj obj_routconst) str)
-  (let ((kval (obj_routconst-kval obj))
-	(kwhy (obj_routconst-kwhy obj))
-	)
-    (cond ( (symbolp kval)
-	    (format str "/*constsymb ~S ? ~S*/" kval kwhy) )
-	  ( (obj_data-p kval)
-	    (format str "/*const[~S] ~S ? ~S*/" 
-		    (type-of kval) (obj_data-comname kval) kwhy)
-	    )
-	  ( t
-	    (format str "/*const/ty[~S] ? ~S*/" (type-of kval) kwhy)))
-    (format str "curfrout->tabval[~d]"
-	    (obj_routconst-koffset obj))
-    ))
-
-
-(defstruct (obj_mkclosure (:include obj_instr))
-  dest 					;optional destination
-  cfun					;closure function
-  cvals					;closed values
-  kobjrout				;closure object routine constant
-)
-
-(defmethod put_destination ((obj obj_mkclosure) dest)
-  (setf (obj_mkclosure-dest obj) dest)
-  nil
-)
-
-(defmethod get_destination ((obj  obj_mkclosure))
-  (obj_mkclosure-dest obj)
-)
-
-(defmethod output_ccode ((obj obj_mkclosure) str)
-  (format str "{")
-  ;(format_c_comment str "**mkclosure ~S ~%**~%" obj)
-  (let ( ( cvals (obj_mkclosure-cvals obj))
-	 ( dest (obj_mkclosure-dest obj))
-	 ( cfun (obj_mkclosure-cfun obj))
-	 ( kobjrout (obj_mkclosure-kobjrout obj))
-	 )
-    (format str " struct BASILYS_CLOSURE_STRUCT(~d) *newclos_=0;~%"
-	    (my_length_gt_1 cvals))
-    (format str " newclos_ = basilysgc_allocate(sizeof(*newclos_),0);~%")
-    (format str " newclos_->discr = (void*)BASILYSG(DISCR_CLOSURE);~%")
-    (format str " newclos_->nbval = ~d;~%"  (length cvals))
-    (if dest
-	(progn (output_ccode dest str) (format str " = (void*)newclos_;~%")))
-    (format str " newclos_->rout = ")
-    (output_ccode kobjrout str)
-    (format str ";~%")
-    (loop
-      for crk from 0
-      for cva in cvals
-      do
-      (format str "newclos_->tabval[~d] = " crk)
-      (output_ccode cva str)		;
-      (format str ";~%")
-      )
-    )
-  (format str "}/**end mkclosure*/~%")
-;  (finish-output str)
-  )
-
-(defstruct (obj_block (:include obj_instr))
-  instrs)
-
-(defmethod output_ccode ((obj obj_block) str)
-  (let ((instrs (obj_block-instrs obj)))
-    (format str "{~%")
-    (mapc (lambda (i) 
-	    (if (obj_instr-p i) 
-		(progn 
-		  (output_ccode i str) (format str ";~%"))))
-	  instrs)
-    (format str "}~%")
-;    (finish-output str)
-))
-
-(defmethod query_ctype ((obj obj_block))
-  (let ((lastinstr (last (obj_block-instrs obj))))
-    (and lastinstr (query_ctype (first lastinstr))))
-)
-
-(defmethod put_destination ((obj obj_block) dest)
-  (let ((instrs (obj_block-instrs obj)))
-    (let ( (l (last instrs) ))
-      (if (consp l) 
-	  (let ( (nd (put_destination (first l) dest)) )
-	    (if nd (setf (first l) nd))
-	    )
-      ))
-    nil
-    ))
-
-(defmethod get_destination ((obj obj_block))
-  (let ((instrs (obj_block-instrs obj)))
-    (let ( (l (last instrs) ))
-      (if (consp l) (get_destination (first l))))))
-  
-
-(defstruct (obj_if (:include obj_instr))
-  ob_cond ob_then ob_else)
-
-(defmethod output_ccode ((obj obj_if) str)
-  (let ( (ocond (obj_if-ob_cond obj))
-	 (othen (obj_if-ob_then obj))
-	 (oelse (obj_if-ob_else obj)) )    
-    (format str "{ /*if*/~%")
-    (if (obj_instr-p ocond) (error "too complex (objinstr) cond in obj_if ~S" obj))
-    (format str " if (")
-    (output_ccode ocond str)
-    (format str ") {/*then*/~%")
-    (output_ccode othen str)
-    (if oelse 
-	(progn
-	  (format str "} else {~%")
-	  (output_ccode oelse str)
-	  (format str "}~%"))
-      (format str "}/*noelse*/;~%"))
-    (format str "} /*endif*/~%")
-))
-
-
-(defmethod query_ctype ((obj obj_if))
-  (let ( (ocond (obj_if-ob_cond obj))
-	 (othen (obj_if-ob_then obj))
-	 (oelse (obj_if-ob_else obj)) )    
-    (let ( (tythen (query_ctype othen)))
-      (if oelse
-	  (and (eq (query_ctype oelse) tythen) tythen)
-	tythen)
-)))
-
-
-
-(defmethod put_destination ((obj obj_if) dest)
-  (let ( (ocond (obj_if-ob_cond obj))
-	 (othen (obj_if-ob_then obj))
-	 (oelse (obj_if-ob_else obj)) )
-;    (and othen (get_destination othen) oelse (get_destination oelse)
-;	 (error "obj_if ~S already got destination in ~S" 
-;		obj (obj_routine-syname (compilation-currout this_compilation))))
-    (let ((dthen (put_destination othen dest))
-	  (delse (if oelse (put_destination oelse dest) 
-		   (build_obj_compute dest (list "NULL") (query_ctype othen)))))
-      (if dthen (setf (obj_if-ob_then obj) dthen))
-      (if delse (setf (obj_if-ob_else obj) delse))
-      )
-    nil
-))
-
-
-(defmethod get_destination  ((obj obj_if))
-  (let ( (ocond (obj_if-ob_cond obj))
-	 (othen (obj_if-ob_then obj))
-	 (oelse (obj_if-ob_else obj)) )
-    (if oelse
-	(and (eq (get_destination othen) (get_destination oelse))
-	     (get_destination othen))
-      (get_destination othen)
-    )))
-
-
-
-;;;;;;;;;;; calls & sends
-
-;;;; calls
-(defstruct (obj_call (:include obj_instr))
-  dest					;main destination
-  clos					;called closure
-  xtraresults				;other results
-  args					;arguments
-  )
-
-
-
-(defmethod output_ccode ((obj obj_call) str)
-  (let* ( (dest (obj_call-dest obj))
-	  (clos (obj_call-clos obj))
-	  (xresults (obj_call-xtraresults obj))
-	  (argseq (obj_call-args obj)) 
-	  (arg1 (and (consp argseq) (car argseq))) 
-	  (revargtypeseq nil)
-	  (revrestypeseq nil)
-	  (oargs (and (consp argseq) (cdr argseq)))
-	  )
-    (format str "/*-*call:*/~%{" obj)
-    (if xresults
-	(format str " union basilysparam_un restab[~d];~%" (length xresults)))
-    (if oargs
-	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
-    (if xresults
-	(format str " memset(restab, 0, sizeof(restab));~%"))
-    (if oargs
-	(format str " memset(argtab, 0, sizeof(argtab));~%"))
-    (loop for ark from 0 for arg in oargs do
-	  (case (query_ctype arg)
-		(:long 
-		 (format str " argtab[~d].bp_long = " ark)
-		 (output_ccode arg str)
-		 (push "BPARSTR_LONG" revargtypeseq)
-		 (format str ";~%")
-		 )
-		(:cstring 
-		 (format str " argtab[~d].bp_cstring = " ark)
-		 (output_ccode arg str)
-		 (push "BPARSTR_CSTRING" revargtypeseq)
-		 (format str ";~%")
-		 )
-		((:value nil) 
-		 (if arg 
-		     (progn
-		       (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
-		       (output_ccode arg str)
-		       (push "BPARSTR_PTR" revargtypeseq)
-		       (format str ");~%"))
-		   (format str " argtab[~d].bp_aptr /*nil arg*/ = NULL;~%")))
-		(otherwise (error "output_ccode obj_call cannot handle arg ~s in ~s" arg obj)))
-	  )
-    (loop for resrk from 0 for xres in xresults do
-	  (case (query_ctype xres)
-		(:long (format str " restab[~d].bp_longptr = & (" resrk)
-		       (output_ccode xres str)
-		       (push "BPARSTR_LONG" revrestypeseq)
-		       (format str ");~%"))
-		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
-		 (output_ccode xres str)
-		 (push "BPARSTR_PTR" revrestypeseq)
-		 (format str ");~%"))
-		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
-	  )
-    (cond
-     ((obj_ptrvar-p dest) 
-      (format str "/*ptrappl*/ basilys_checked_assign(")
-      (output_ccode dest str)
-      (format str " = "))
-     ((null dest)
-      (format str "/*nodestappl*/ (void) "))
-     (dest
-      (assert (not (obj_longvar-p dest)) (dest obj) "output_ccode objcall dest ~S obj ~S" dest obj)
-      (format str "/*noptrappl*/")
-      (output_ccode dest str)
-      (format str " = "))
-     )
-    (format str "basilys_apply(((void*)(")
-    (output_ccode clos str)
-    (format str ")), (")
-    (output_ccode arg1 str)
-    (format str "),~%   (")
-    (loop for argtype in (reverse revargtypeseq) do 
-	  (format str " ~a" argtype))
-    (format str " \"\"), ")
-    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
-    (format str ", ~%  (")
-    (loop for restype in (reverse revrestypeseq) do 
-	  (format str " ~a" restype))
-    (format str " \"\"), ")
-    (if xresults (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
-    (if
-	(obj_ptrvar-p dest)
-	(format str "));~%")
-      (format str ");~%"))
-    (format str "~%} /*endcall*/ ~%")
-					;    (finish-output str)
-    )
-  )
-
-(defmethod put_destination ((obj obj_call) dest)
-  (setf (obj_call-dest obj) dest)
-  nil
-)
-
-(defmethod get_destination ((obj obj_call))
-  (obj_call-dest obj)
-)
-
-
-
-;;;; sends
-(defstruct (obj_send (:include obj_instr))
-  obs_dest					;main destination result
-  obs_sel					;selector
-  obs_xtraresults				;other results
-  obs_recv					;reciever
-  obs_args					;arguments
-  )
-
-
-(defmethod output_ccode ((obj obj_send) str)
-  (let ( (odest (obj_send-obs_dest obj))
-	 (osel (obj_send-obs_sel obj))
-	 (oxtrares (obj_send-obs_xtraresults obj))
-	 (orecv (obj_send-obs_recv obj))
-	 (oargs (obj_send-obs_args obj)) 
-	 (revargtypeseq nil)
-	 (revrestypeseq nil)
-	 )
-    (format str "/*-*send:*/~%{" obj)
-    (if oxtrares
-	(format str " union basilysparam_un restab[~d];~%" (length oxtrares)))
-    (if oargs
-	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
-    (if oxtrares
-	(format str " memset(restab, 0, sizeof(restab));~%"))
-    (if oargs
-	(format str " memset(argtab, 0, sizeof(argtab));~%"))
-    (loop for ark from 0 for arg in oargs do
-	  (case (query_ctype arg)
-		(:long
-		 (format str " argtab[~d].bp_long = " ark)
-		 (output_ccode arg str)
-		 (push "BPARSTR_LONG" revargtypeseq)
-		 (format str ";~%")
-		 )
-		(:cstring 
-		 (format str " argtab[~d].bp_cstring = " ark)
-		 (output_ccode arg str)
-		 (push "BPARSTR_CSTRING" revargtypeseq)
-		 (format str ";~%")
-		 )
-		((:value nil) 
-		 (if arg 
-		     (progn
-		       (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
-		       (output_ccode arg str)
-		       (push "BPARSTR_PTR" revargtypeseq)
-		       (format str ");~%"))
-		   (progn
-		     (format str " argtab[~d].bp_aptr = /*nilarg*/NULL;~%")
-		     )))
-		(otherwise (error "output_ccode obj_callcannot handle arg ~s in ~s" arg obj)))
-	  )
-    (loop for resrk from 0 for xres in oxtrares do
-	  (case (query_ctype xres)
-		(:long (format str " restab[~d].bp_longptr = & (" resrk)
-		       (output_ccode xres str)
-		       (push "BPARSTR_LONG" revrestypeseq)
-		       (format str ");~%"))
-		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
-		 (output_ccode xres str)
-		 (push "BPARSTR_PTR" revrestypeseq)
-		 (format str ");~%"))
-		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
-	  )
-    (if odest
-	(progn 
-	  (output_ccode odest str)
-	  (format str " = "))
-      (format str "(void) "))
-    (format str "basilysgc_send(((void*)(")
-    (output_ccode orecv str)
-    (format str ")), (")
-    (output_ccode osel str)
-    (format str "),~%   (")
-    (loop for argtype in (reverse revargtypeseq) do 
-	  (format str " ~a" argtype))
-    (format str " \"\"), ")
-    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
-    (format str ", ~%  (")
-    (loop for restype in (reverse revrestypeseq) do 
-	  (format str " ~a" restype))
-    (format str " \"\"), ")
-    (if oxtrares (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
-    (format str ");~%")
-    (format str "~%} /*endsend*/ ~%")
-					;    (finish-output str)
-    ))
-
-
-(defmethod put_destination ((obj obj_send) dest)
-  (setf (obj_send-obs_dest obj) dest)
-  nil
-)
-
-(defmethod get_destination ((obj obj_send))
-  (obj_send-obs_dest obj)
-)
-
-;;;;;;;;;;; forever instruction
-
-(defstruct (obj_forever (:include obj_instr))
-  obforever_bind					;forever binding
-  obforever_res					;result
-  obforever_dest					;forever destination
-  obforever_body					;body
-  obforever_epilogue			;epilogue
-  )
-
-(defmethod put_destination ((obj obj_forever) dest)
-  (setf (obj_forever-obforever_dest obj) dest)
-  nil
-)
-
-(defmethod get_destination ((obj obj_forever))
-  (obj_forever-obforever_dest obj)
-)
-
-
-(defmethod output_ccode ((obj obj_forever) str)
-  (let* ( (lbind (obj_forever-obforever_bind obj))
-	  (lres  (obj_forever-obforever_res obj))
-	  (ldest (obj_forever-obforever_dest obj))
-	  (lepil (obj_forever-obforever_epilogue obj))
-	  (lbody (obj_forever-obforever_body obj)) 
-	  (luniq (cold_forever_binding-uniq lbind))
-	  )
-    (format str "/*forever ~S*/{~%" luniq)
-    (output_ccode lres str)
-    (format str " = 0;~%")
-    (format str " lab_startforever_~a:;~%" (string luniq))
-    (loop for rk from 1 for ins in lbody do
-	  (format str "/*forever ~S instr#~d*/" luniq rk)
-	  (output_ccode ins str)
-	  (format str ";~%"))
-    (format str "/*againforever*/ goto lab_startforever_~a;~%" (string luniq))
-    (format str " lab_endforever_~a:;~%" (string luniq))
-    (if ldest 
-	(progn
-	  (format str "/*foreverdest ~S*/~%" luniq)
-	  (output_ccode ldest str)
-	  (format str " = ")
-	  (output_ccode lres str)
-	  (format str ";~%")
-	  ))
-    (if lepil
-	(progn
-	  (format str "/*foreverdest ~S*/~%" lepil)
-	  (output_ccode lepil str)
-	  (format str ";~%")
-	  ))
-    (format str "/*endforever ~S*/}~%" luniq)
-;    (finish-output str)
-    ))
-		
-;;;;
-
-(defstruct (obj_exit (:include obj_instr))
-  obxit_bind 
-  obxit_body
-)
-
-(defmethod put_destination ((obj obj_exit) dest)
-  nil
-)
-
-(defmethod output_ccode ((obj obj_exit) str)
-  (let ( (xuniq (cold_forever_binding-uniq (obj_exit-obxit_bind obj))) )
-    (format str "{ /*Exit ~S*/~%" xuniq)
-    (loop for irk from 1
-	  for ins in (obj_exit-obxit_body obj)
-	  do
-	  (format str "/*exiting ~S ins#~d*/~%" xuniq irk)
-	  (output_ccode ins str)
-	  (format str ";~%"))
-    (format str " /*exitjump*/ goto lab_endforever_~a;~%" (string xuniq))
-    (format str "} /*end Exit ~S*/~%" xuniq)
-))
-
-;;;;;;;;;;; return instruction
-(defstruct (obj_return (:include obj_instr))
-  mainreturn				;the main returned value
-  extrareturns				;the sequence of extra returned values
-)
-
-(defmethod put_destination ((obj obj_return) dest)
-  (let ((nmd (put_destination (obj_return-mainreturn obj) dest))) 
-    (if nmd (setf (obj_return-mainreturn obj) nmd))
-    ))
-
-
-(defmethod output_ccode ((obj obj_return) str)
-  (format str "/*-*Returning**/ {~%")
-  (format_c_comment str "objreturn ~s" obj)
-  (let ( 
-	(mainret (obj_return-mainreturn obj))
-	(xtrarets (obj_return-extrareturns obj))
-	)
-    (if (null mainret) 
-	(format str "/*no retval*/ curfptr[0] = (void*)0 ")
-      (let ( (maindest (get_destination mainret)) )
-	(format_c_comment str "mainret ~S maindest ~S" mainret maindest)
-	(if (not (eq maindest cold_return_var))
-	    (format str "/*simple retval*/ curfptr[0] = ")
-	  (format str "/*got retval*/ "))
-	(output_ccode mainret str)
-	))
-    (format str ";~%")
-    (if xtrarets 
-	(format str " if (!xrestab_ || !xresdescr_) goto lab_endrout;~%"))
-    (loop
-     for ark from 0
-     for ret in xtrarets 
-     do
-     (format_c_comment str "*!* extra result #~d = ~s *~%" ark ret)
-     (let ( (rettype (query_ctype ret)) )
-       (case rettype
-	     (:long 
-	      (format str " if (xresdescr_[~d] != BPAR_LONG) goto lab_endrout;~%" ark)
-	      (format str " if (xrestab_[~d].bp_longptr)~%     *(xrestab_[~d].bp_longptr) = (" ark ark)
-	      (output_ccode ret str)
-	      (format str ");~%")
-	      )
-	     ((:value nil) 
-	      (format str " if (xresdescr_[~d] != BPAR_PTR) goto lab_endrout;~%" ark)
-	      (format str " if (xrestab_[~d].bp_aptr)~%     *(xrestab_[~d].bp_aptr) = (void*) (" ark ark)
-	      (output_ccode ret str)
-	      (format str ");~%")
-	      )
-	     (otherwise (error "bad return type ~s in ~s" rettype obj))
-	     )
-       )))
-  (format str " goto lab_endrout;~%")
-  (format str "} /*end return*/~%")
-;  (finish-output str)
-  )
-
-
-(defstruct (obj_routine (:include obj_instr))
-  pfun					;prog function
-  syname				;symbol for easier naming it (or nil)
-  rank					;integer rank of this function
-  obody					;sequence of C instr
-  nbptr					;total number of pointer variables
-  nbnum					;total number of long variables
-  nbdouble				;total number of double variables
-  nbcstring				;total number of cstring variables
-  freevptrs				;list of free varptr to be reused
-  freevnums				;list of free varlong to be reused
-  freevdbls				;list of free vardbl to be reused
-  freevcstrings				;list of free varcstring to be reused
-  dataclos				;the associated dataclosure
-  datarout				;the associated dataroutine
-  data2ptrhash				;hash associating data to pointers
-)
-
-(defmethod  print-object ((ob obj_routine) st)
-  (format st "ObjRoutine{SyName=~S Obody=~S DataClos=~S DataRout=~S}" 
-	  (obj_routine-syname ob)
-	  (obj_routine-obody ob)
-	  (obj_routine-dataclos ob)
-	  (obj_routine-datarout ob)
-	  ))
-
-
-(defun routine_link_data2ptr (orout odata ptr)
-  (assert (obj_routine-p orout))
-  (assert (obj_data-p odata))
-  (assert ptr)
-  (setf (gethash odata (obj_routine-data2ptrhash orout)) ptr)
-)
-
-(defun routine_get_ptr4data (orout odata)
-  (assert (obj_routine-p orout))
-  (assert (obj_data-p odata)) 
-  (gethash odata (obj_routine-data2ptrhash orout))
-)
-
-(defun currout_data2ptr (odata)
-  (assert (obj_data-p odata))
-  (let ( (currout
-	  (or (compilation-currout this_compilation)
-	      (compilation-initrout this_compilation))) )
-    (assert (obj_routine-p currout))
-    (routine_get_ptr4data currout odata)
-))
-
-(defun currout_link_data2ptr (odata ptr)
-  (assert (obj_data-p odata))
-  (let ( (currout
-	  (or (compilation-currout this_compilation)
-	      (compilation-initrout this_compilation))) )
-    (assert (obj_routine-p currout)) 
-    (routine_link_data2ptr currout odata ptr)
-))
-
-(defun routinecname (rou) 
-  (if (obj_routine-p rou)
-      (let ( (rk (obj_routine-rank rou))
-	     (sn (obj_routine-syname rou)) )
-	(if (symbolp sn)
-	    (let ( (tsn (map 'string (lambda (c) (if (alphanumericp c) c #\_)) (symbol-name sn))) )
-	      (format nil "rout__~d__~a" rk tsn))
-	  (format nil "rout__~d" rk)))))
-
-(defmethod output_ccode ((obj obj_routine) str)
-  (let ( (rk (obj_routine-rank obj)) 
-	 (nbptr (obj_routine-nbptr obj))
-	 (nbnum (obj_routine-nbnum obj))
-	 (nbdouble (obj_routine-nbdouble obj))
-	 (nbcstring (obj_routine-nbcstring obj))
-	 (oldcurout (compilation-currout this_compilation))
-	 )
-    (setf (compilation-currout this_compilation) obj)
-    (format str "~%~% /*** C routine ~d <~S> **/~%" rk (obj_routine-syname obj))
-    ;; (format_c_comment str "** routine ~S ~& routine rank ~d  **~%" obj rk)
-    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
-    (format str "     	     basilys_ptr_t firstargp_,~%")
-    (format str "	    	     const char xargdescr_[],~%")
-    (format str "              union basilysparam_un* xargtab_,~%")
-    (format str "              const char xresdescr_[],~%")
-    (format str "              union basilysparam_un* xrestab_)~%{~%")
-    (format str "#if ENABLE_CHECKING~%")
-    (format str "  static long thiscallcounter__;~%")
-    (format str "  long callcount_ = ++thiscallcounter__;~%")
-    (format str "#define callcount callcount_~%")
-    (format str "#else~%")
-    (format str "#define callcount 0L~%")
-    (format str "#endif~%")
-    (format str "  struct {~%")
-    (format str "    unsigned nbvar;~%")
-    (format str "#if ENABLE_CHECKING~%")
-    (format str "  const char* flocs;~%")
-    (format str "#endif~%")
-    (format str "    struct basilysclosure_st* clos;~%")
-    (format str "    struct excepth_basilys_st* exh;~%")
-    (format str "    struct callframe_basilys_st* prev;~%")
-    (format str "    void* varptr[COLD_EXTRAGAP+ ~d];~%" (+ nbptr 1))
-    (format str "    long varnum[COLD_EXTRAGAP+ ~d];~%" (+ nbnum 1))
-    (format str "    double vardbl[COLD_EXTRAGAP+ ~d];~%" (+ nbdouble 1))
-    (format str "    const char* varcstring[COLD_EXTRAGAP+ ~d];~%" (+ nbcstring 1))
-    (format str "    long _spare_;~%")
-    ;; @@@ the real nbvar should be nbptr but we have a bug somewhere...
-    (format str "  } curfram__ = { /*nbvar*/~d,~%" (+ nbptr 1)) 
-    (format str "#if ENABLE_CHECKING~%")
-    (format str "  (char*)0,~%")
-    (format str "#endif~%")
-    (format str "   (struct basilysclosure_st*)0,~%")
-    (format str "   (struct excepth_basilys_st*)0,~%")
-    (format str "   (struct callframe_basilys_st*)0, ~%")
-    (progn 
-      (format str "/*~d ptrvars:*/ {" nbptr)
-      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
-      (format str "}, ~%")
-      ) 
-    (progn 
-      (format str "/*~d numvars:*/ {" nbnum)
-      (loop for ix from 1 to nbnum do (format str " 0L,"))
-      (format str " 0L }, ~%")
-      )
-    (progn 
-      (format str "/*~d doublevars:*/ {" nbdouble)
-      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
-      (format str " 0.0 }, ~%")
-      )
-    (let ( (ofunam (string (obj_routine-syname obj))) )
-      (if (and (> (length ofunam) 9) (string= (subseq ofunam 0 9) "_LAMBDAFUN"))
-	  (setq ofunam "LAMBDA"))
-      (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_trace_start(\"~A\", callcount);~%" ofunam)
-      (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_trace_end(\"~A\", callcount);~%" ofunam)
-      (format str " basilys_topframe= (void*)(curfram__.prev); return curfram__.varptr[0];~%")
-      (format str "#undef callcount~%")
-      (format str "} /* end rout_~d */~%~%" rk))
-    (setf (compilation-currout this_compilation) oldcurout)
-    (finish-output str)
-    ))
-
-
-
-(defmethod output_cdecl ((obj obj_routine) str)
-  (let ((rk (obj_routine-rank obj)))
-    (format str "~%/** declroutine routine rank ~d  **/~%" 
-	    rk)
-    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
-    (format str "     	     basilys_ptr_t firstargp_,~%")
-    (format str "	    	     const char xargdescr_[],~%")
-    (format str "              union basilysparam_un* xargtab_,~%")
-    (format str "              const char xresdescr_[],~%")
-    (format str "              union basilysparam_un* xrestab_);~%")
-    ))
-
-
-;; make a pointer variable inside a routine, using the free list if possible
-;; orout is the object routine inside which it is used
-;; bind is the binding
-;; why is some explanation string
-(defun newobjptrvar (orout bind why)
-  (assert (obj_routine-p orout))
-  (assert (cold_any_binding-p bind))
-  (if why (assert (stringp why)))
-  (if (consp (obj_routine-freevptrs orout))
-      (let ( (fvar (pop (obj_routine-freevptrs orout))) )
-	(assert (obj_ptrvar-p fvar))
-	(assert (obj_var-vfree fvar))
-	(assert (eq (obj_var-vrout fvar) orout))
-	;; don't reuse fvar for ease of debugging but make a new var of same offset
-	(let ( (rvar (copy-obj_ptrvar fvar)) )
-	  (setf (obj_var-vbind rvar) bind)
-	  (setf (obj_var-vwhy rvar) why)
-	  (setf (obj_var-vfree fvar) rvar)
-	  (setf (obj_var-vfree rvar) nil)
-	  rvar
-	))
-    (let ( (nvar (make-obj_ptrvar :vbind bind 
-				  :voffset (incf (obj_routine-nbptr orout))
-				  :vwhy why
-				  :vrout orout)) )
-      nvar
-      )))
-
-;; free a pointer variable to enable its reuse
-(defun freeobjptrvar (ovar)
-  (assert (obj_ptrvar-p ovar))
-  (assert (cold_any_binding-p (obj_var-vbind ovar)))
-  (let ( (orout (obj_var-vrout ovar)) 
-	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
-	 )
-    (assert (obj_routine-p orout))
-    (push ovar (obj_routine-freevptrs orout))
-    (setf (obj_var-vfree ovar) t)
-    nil
-))
-
-
-;; make a long variable inside a routine, using the free list if possible
-;; orout is the object routine inside which it is used
-;; bind is the binding
-;; why is some explanation string
-(defun newobjlongvar (orout bind why)
-  (assert (obj_routine-p orout))
-  (assert (cold_any_binding-p bind))
-  (if why (assert (stringp why)))
-  (if (consp (obj_routine-freevnums orout))
-      (let ( (fvar (pop (obj_routine-freevnums orout))) )
-	(assert (obj_longvar-p fvar))
-	(assert (obj_var-vfree fvar))
-	(assert (eq (obj_var-vrout fvar) orout))
-	;; don't reuse fvar for ease of debugging but make a new var of same offset
-	(let ( (rvar (copy-obj_longvar fvar)) )
-	  (setf (obj_var-vbind rvar) bind)
-	  (setf (obj_var-vwhy rvar) why)
-	  (setf (obj_var-vfree fvar) rvar)
-	  (setf (obj_var-vfree rvar) nil)
-	  rvar
-	))
-    (let ( (nvar (make-obj_longvar :vbind bind 
-				  :voffset (incf (obj_routine-nbnum orout))
-				  :vwhy why
-				  :vrout orout)) )
-      nvar
-      )))
-
-;; free a long variable to enable its reuse
-(defun freeobjlongvar (ovar)
-  (assert (obj_longvar-p ovar))
-  (assert (cold_any_binding-p (obj_var-vbind ovar)))
-  (let ( (orout (obj_var-vrout ovar)) 
-	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
-	 )
-    (assert (obj_routine-p orout))
-    (push ovar (obj_routine-freevnums orout))
-    (setf (obj_var-vfree ovar) t)
-    nil
-))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; make a cstring variable inside a routine, using the free list if possible
-;; orout is the object routine inside which it is used
-;; bind is the binding
-;; why is some explanation string
-(defun newobjcstringvar (orout bind why)
-  (assert (obj_routine-p orout))
-  (assert (cold_any_binding-p bind))
-  (if why (assert (stringp why)))
-  (if (consp (obj_routine-freevcstrings orout))
-      (let ( (fvar (pop (obj_routine-freevnums orout))) )
-	(assert (obj_cstringvar-p fvar))
-	(assert (obj_var-vfree fvar))
-	(assert (eq (obj_var-vrout fvar) orout))
-	;; don't reuse fvar for ease of debugging but make a new var of same offset
-	(let ( (rvar (copy-obj_cstringvar fvar)) )
-	  (setf (obj_var-vbind rvar) bind)
-	  (setf (obj_var-vwhy rvar) why)
-	  (setf (obj_var-vfree fvar) rvar)
-	  (setf (obj_var-vfree rvar) nil)
-	  rvar
-	))
-    (let ( (nvar (make-obj_cstringvar :vbind bind 
-				  :voffset (incf (obj_routine-nbnum orout))
-				  :vwhy why
-				  :vrout orout)) )
-      nvar
-      )))
-
-;; free a cstring variable to enable its reuse
-(defun freeobjcstringvar (ovar)
-  (assert (obj_cstringvar-p ovar))
-  (assert (cold_any_binding-p (obj_var-vbind ovar)))
-  (let ( (orout (obj_var-vrout ovar)) 
-	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
-	 )
-    (assert (obj_routine-p orout))
-    (push ovar (obj_routine-freevcstrings orout))
-    (setf (obj_var-vfree ovar) t)
-    nil
-))
-
-
-(defgeneric compile_obj (cod env)
-  (:documentation "compilation of (any) Basilys code")
-)
-
-(defmethod compile_obj ((cod t) env)
-  (break "compile_obj t cod ~S~%! env ~S~%!  ~% <<<compilobj t" 
-	  cod env)
-  cod
-)
-
-(defmethod compile_obj ((cod cons) env)
-  (error "compile_obj consp cod ~S~%! env ~S~%!  ~% <<<compilobj cons" 
-	  cod env)
-  cod
-)
-
-(defmethod compile_obj ((cod integer) env)
-  cod
-)
-
-(defmethod compile_obj ((cod string) env)
-  cod
-)
-
-(defmethod compile_obj ((cod prog_cstring) env)
-  (make-obj_cstring :obcstr (prog_cstring-c_str cod))
-)
-
-;; the sole init routine has to be a subclass of objoutine to handle
-;; appropriately objpointers
-(defstruct (obj_initroutine (:include obj_routine))
-  inirou_datarankdict			;dictionnary mapping data to its rank
-)
-
-;; given a data, returns its integer rank in the initial routine or else nil
-(defun initrout_rank (obda)
-  (let ( (hrk 
-	  (gethash obda 
-		  (obj_initroutine-inirou_datarankdict
-		   (compilation-initrout this_compilation)))) )
-    ; to ease readability of the initrout we try to match the rank
-    ; with the varptr index into which it is usually stored
-    (if (integerp hrk) (+ hrk 2))
-))
-
-(defmethod output_cdecl ((obj obj_initroutine) str)
-  (format str  "~%~%/*-* declinitroutine  *-*/~%")
-  (format str "void* start_module_basilys(void*modata_);~%")
-)
-
-
-(defmethod output_ccode ((obj obj_initroutine) str)
-  (let ( (nbptr (obj_routine-nbptr obj))
-	 (nbnum (obj_routine-nbnum obj))
-	 (nbdouble (obj_routine-nbdouble obj))
-	 (cdata (reverse (compilation-cdata this_compilation)))
-	 (oldcurout (compilation-currout this_compilation))
-	 )
-    (setf (compilation-currout this_compilation) obj)
-    ;; (format str "~%~%/*-* initroutine~% ~S  **/~%" obj)
-    (format str "~%~%~%~%~%~%/*######### ccode initroutine ############*/~%")
-    (format str "void* start_module_basilys(void*modata_) {~%")
-    (format str "/*-*cdatalen ~d **/~%" (length cdata))
-    (format str " typedef struct cdata_st {~%")
-    (loop for rk from 0 for da in cdata do
-	  (format str "/*cdata ~d*/~%" rk)
-					;(format_c_comment str "**cdata #~d = ~s~%" rk da)
-	  (output_cdecl da str)
-	  )
-    (format str " long _extragap[2];} cdata_t;~%") 
-    (format str " cdata_t*cdat=0;~%")
-    (format str "  struct {~%")
-    (format str "    unsigned nbvar;~%")
-    (format str "    struct basilysclosure_st* clos;~%")
-    (format str "    struct excepth_basilys_st* exh;~%")
-    (format str "    struct callframe_basilys_st* prev;~%")
-    (format str "   void* varptr[~d];~%" (+ nbptr 1))
-    (format str "    long varnum[~d];~%" (+ nbnum 1))
-    (format str "    double vardbl[~d];~%" (+ nbdouble 1))
-    (format str "    long _extra_;~%" )
-    (format str "  } curfram__ = { /*nbvar*/~d,~%" nbptr)
-    (format str "   (struct basilysclosure_st*)0,~%")
-    (format str "   (struct excepth_basilys_st*)0,~%")
-    (format str "   (struct callframe_basilys_st*)0, ~%")
-    (progn 
-      (format str "/*~d ptrvars:*/ {" nbptr)
-      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
-      (format str "}, ~%")
-      )
-    (if (> nbnum 0) (progn 
-      (format str "/*~d numvars:*/ {" nbnum)
-      (loop for ix from 1 to nbnum do (format str " 0L,"))
-      (format str "}, ~%")
-      ))
-    (if (> nbdouble 0) (progn 
-      (format str "/*~d doublevars:*/ {" nbdouble)
-      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
-      (format str "}, ~%")
-      ))
-    (format str " 0L};~% curfram__.prev = basilys_topframe;~%")
-    (format str " basilys_topframe= (void*)(&curfram__);~%")
-    (format str "/*allocating and assigning cdata*/ {~%;~%")
-    (format str " debugeprintf(\"generated cdatlen ~d : size %d bytes\", (int)sizeof(cdata_t));~%" 
-	    (length cdata))
-    (format str " cdat = basilysgc_allocate(sizeof(cdata_t),0);~%")
-    (format str " debugeprintf(\" cdat %p - %p\", (void*)cdat, (void*)((char*)cdat + sizeof(cdata_t)));~%")
-    (loop for rk from 0 for da in cdata do
-	  (format str "~%/* assign cdata #~d*/~%" rk)
-	  (output_cassign da str)	
-	  )
-    (format str "/***** initcdata ***/~%")
-    (loop for rk from 0 for da in cdata do
-	  (format str "~%/* init cdata #~d*/~%" rk)
-	  (output_cinit da str)	
-	  (format str "~%/* endinit cdata #~d*/~%" rk)
-	  )
-    (format *error-output* ";;wrote ~d init cdata ~g cpusec~%" (length cdata) (cpusec))
-    (finish-output str)
-    (format str "} /*allocated, assigned, inited cdata*/~%")
-    (format str "/*filling cdata ****/~%")
-    (loop for rk from 0 for da in cdata do
-	  (format str "~%/* fill cdata #~d*/~%" rk)
-	  (output_cfill da str)	
-	  )
-    (finish-output str)
-    (format *error-output* ";;wrote ~d fill cdata ~g cpusec~%" (length cdata) (cpusec))
-    (format str "/*verifying cdata ****/~%")
-    (loop for rk from 0 for da in cdata do
-	  (format str "~%/* verify cdata #~d*/~%" rk)
-	  (output_cverify da str)	
-	  )
-    (format str "/*body of initrout*/~%")
-    (format *error-output* ";;before writing init body ~g cpusec~%" (cpusec))
-    (format str " debugeprintf(\"before init routine body\");~%")
-    (if (obj_routine-obody obj)  (output_ccode (obj_routine-obody obj) str))
-    (format str "; /* initrout body end */~%")
-    (let ( (nbsym (hash-table-count(compilation-symboldict this_compilation))) )
-      (format str "/*intern ~d symbols*/~%" nbsym)
-      (format *error-output* ";;writing init ~d interning ~g cpusec~%" nbsym (cpusec))
-      )
-    (let ( (symlist nil) ) 
-      (maphash (lambda (sym data) (push sym symlist)) 
-	       (compilation-symboldict this_compilation))
-      (let ( (sortedsymlist (sort symlist (lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2))))) )
-	(mapc (lambda (sym)
-		(let ( (sydata (gethash sym (compilation-symboldict this_compilation))) )
-					; (format_c_comment str "symbol ~S data ~S~%" sym sydata)
-		  (format str "/*interning ~S*/~%" sym)
-		  (if (keywordp sym)
-		      (format str "(void) basilysgc_intern_keyword(")
-		    (format str "(void) basilysgc_intern_symbol("))
-		  (output_ccode sydata str)
-		  (format str ");~%")
-		  ))
-	      sortedsymlist)))
-    (format str " goto lab_endrout;~%")
-    (format str " lab_endrout:~% debugeprintf(\"end init routine returning %p\", curfptr[0]);~%")
-    (format str " basilys_topframe= (void*)(curfram__.prev); return curfptr[0];")
-    (format str "}/* end start_module_basilys */~%")
-    (setf (compilation-currout this_compilation) oldcurout)
-    (finish-output str)
-    ))
-
-;;; compilation of nil
-(defmethod compile_obj ((cod null) env)
-  (make-obj_verbatim :vstr "/*Nil*/NULL")
-)
-
-
-;; compilation of symbols
-(defmethod compile_obj ((cod symbol) env)
-  (let ((bnd (cold_find_binding cod env)))
-    (or bnd (error "compile_obj symbol: unbound symbol ~s in env ~s~% <::compile_obj unboundsym ~S in ~S>" 
-		   cod env cod (obj_routine-syname (compilation-currout this_compilation))))
-    (cond ( (cold_value_binding-p bnd)
-	    (let ( (sdata (cold_value_binding-val bnd)) )
-	      (cond
-	       ( (eq (cold_value_binding-type bnd) :void)
-		 (make-obj_verbatim :vstr (format nil "/*Void ~S*/NULL" cod)))
-	       ( (obj_var-p sdata) sdata)
-	       ( (currout_data2ptr sdata) )
-	       ( t (newobjconst sdata "symb val"))
-	       )))
-	  ( (cold_class_binding-p bnd)
-	    ;; a class is a constant, to be put in the routine's constant data
-	    (let ( (cladata  (cold_class_binding-classdata bnd)) )
-	      (assert (obj_data-p cladata) () "compilobj: bad data ~S for class ~S bnd ~S" cladata cod bnd)
-	      (or (currout_data2ptr cladata) (newobjconst cladata "symb class"))
-	      ))
-	  ( (cold_field_binding-p bnd)
-	    (let ( (fldata (cold_field_binding-fieldata bnd)) )
-	      (assert (obj_data-p fldata) ()  "compilobj: bad data ~S for field ~S bnd ~S" fldata cod bnd)
-	      (or (currout_data2ptr fldata) (newobjconst fldata "symb field"))
-	      ))
-	  ( (cold_instance_binding-p bnd)
-	    (let ( (insdata (cold_instance_binding-instancedata bnd)) )
-	      (assert (obj_data-p insdata) ()  "compilobj: bad data ~S for instance ~S bnd ~S" insdata cod bnd)
-	      (or (currout_data2ptr insdata) (newobjconst insdata "symb inst"))
-	      ))
-	  ( (cold_selector_binding-p bnd)
-	    (let ( (seldata (cold_selector_binding-selectordata bnd)) )
-	      (assert (obj_data-p seldata) ()  "compilobj: bad data ~S for selector ~S bnd ~S" seldata cod bnd)
-	      (or (currout_data2ptr seldata) (newobjconst seldata "symb sel"))
-	      ))
-	  ( (cold_function_binding-p bnd)
-	    (let ( (fundata (cold_function_binding-fclodata bnd)) )
-	      (assert (obj_data-p fundata) ()  "compilobj: bad data ~S for function ~S bnd ~S" fundata cod bnd)
-	      (or (currout_data2ptr fundata) (newobjconst fundata "symb fun"))
-	      ))
-	  ( (cold_code_binding-p bnd) 
-	    (compile_obj (cold_code_binding-code bnd) env) )
-	  (t (error "unexpected compile_obj symbol ~s~%!! bnd ~s~%!!env ~s~% <::compile_obj unexpectedsym ~S {bnd ~S} in ~S>" 
-		    cod bnd env cod (type-of bnd)
-		    (obj_routine-syname (compilation-currout this_compilation)))))
-    ))
-
-
-;;; compilation of quoted symbols
-(defmethod compile_obj ((cod prog_quotesym) env)
-  (declare (ignore env))
-  (let ( (qs (prog_quotesym-qsym cod)) )
-    (cond ( (or (symbolp qs) (keywordp qs))
-;	    (warn "compilobj-quotesym cod=~S~%" cod)
-	    (let* ( (odatsym (get_obj_symbol qs "quotesym"))
-		    (osymptr  (currout_data2ptr odatsym))
-		    )
-;	    (warn "compilobj-quotesym odatsym ~S osymptr ~S~%" odatsym osymptr)
-	      (or osymptr (newobjconst odatsym "quotsym"))))
-	  ( t (error "compile_obj bad prog_quotesym ~S" cod) )
-    )
-))
-
-;; compilation of closed variable occurrences
-(defmethod compile_obj ((cod prog_closedvar) env)
-  (let ( (cfun (prog_closedvar-clv_fun cod))
-	 (cvar (prog_closedvar-clv_var cod)) )
-    (let* ( (clovarseq 
-	     (cond
-	      ( (prog_defun-p cfun) (prog_defun-fun_closvars cfun) )
-	      ( (prog_lambda-p cfun) (prog_lambda-lambda_closvars cfun) )
-	      ( t (cerror "compile_obj prog_closedvar bad cfun ~s for cod ~s" cfun cod))))
-	    (coff 
-	     (progn
-	       (position cvar clovarseq
-		:test (lambda (c1 cv2) 
-			(eq (if (symbolp c1) c1 (prog_closedvar-clv_var c1))
-			    (prog_closedvar-clv_var cv2)))))
-	     )
-	    )
-      (or coff (error "compile_obj prog_closedvar no offset for cod ~s ~%... in clovarseq ~S~%" 
-		      cod))
-      (make-obj_closedvar :cvar cvar :cfun cfun :coffset coff)
-      )))
-
-
-;; handling of closed variables in functions' closed variables and constants
-(defun handleclosvar (pcv env)
-  (if (and (prog_closedvar-p pcv)
-	   (prog_defun-p (prog_closedvar-clv_fun pcv)))
-      (let (
-	    (cva (prog_closedvar-clv_var pcv))
-	    )
-	(or (symbolp cva) (error "bad cva in handleclosvar pcv ~S" pcv))
-	(let ( (vbi (cold_find_binding cva env)) )
-	  (cond ( (cold_value_binding-p vbi)
-		 (cold_value_binding-val vbi) )
-		( (cold_class_binding-p vbi)
-		 (cold_class_binding-classdata vbi) )
-		( (cold_field_binding-p vbi)
-		 (cold_field_binding-fieldata vbi) )
-		( (cold_instance_binding-p vbi)
-		 (cold_instance_binding-instancedata vbi) )
-		( (cold_selector_binding-p vbi)
-		 (cold_selector_binding-selectordata vbi) )
-		( (cold_function_binding-p vbi)
-		 (cold_function_binding-fclodata vbi) )
-		( t 
-		 (error "handleclosdata unexpected binding vbi=~S cva=~S" 
-			vbi cva))
-		)
-	  ))
-      (progn
-	pcv)
-      )
-  )
-
-;;;; compilation of progns
-(defmethod compile_obj ((cod prog_progn) env)
-  (let ( (pbody (prog_progn-progn_body cod)) )
-    (make-obj_block :instrs
-		    (mapcar (lambda (comp) (compile_obj comp env)) pbody))
-))
-
-
-;;;; compilation of forevers
-
-(defmethod compile_obj ((cod prog_forever) env)
-  (let* ( (lbind (prog_forever-forever_bind cod))
-	  (lbody (prog_forever-forever_body cod)) 
-	  (lbnam (cold_any_binding-bname lbind))
-	  (luniq (cold_forever_binding-uniq lbind))
-	  (ltype (cold_forever_binding-type lbind))
-	  (epilo nil)
-	  (obody nil)
-	  (lvar nil)
-	  (nbind (make-cold_obforever_binding 
-		  :bname lbnam
-		  :type ltype
-		  :uniq luniq
-		  :lobvar nil))
-	  (newenv (cold_fresh_env env))
-	  )
-    (cold_put_binding nbind newenv)
-    (case ltype
-	  ( :value 
-	    (let ( (vvar 
-		    (newobjptrvar (compilation-currout this_compilation) lbind
-			       "forever value")) )
-	      (setf (cold_obforever_binding-lobvar nbind) vvar)
-	      (setq epilo (make-obj_clearptr :clrptrvar vvar))
-	      (setq lvar vvar)
-	      ))
-	  ( :long 
-	    (let ( (vvar 
-		    (newobjlongvar (compilation-currout this_compilation) lbind
-			       "forever num"
-			       )) )
-	      (setf (cold_obforever_binding-lobvar nbind) vvar)
-	      (setq epilo (make-obj_clearlong :clrlongvar vvar))
-	      (setq lvar vvar)
-	      ))
-	  (otherwise (error "bad forever ltype ~S in ~S" ltype cod))
-	  )
-    (setq obody (mapcar (lambda (i) (compile_obj i newenv)) lbody))
-    (if lvar (case ltype
-	       (:value (freeobjptrvar lvar))
-	       (:long (freeobjlongvar lvar))
-	       ))
-    (make-obj_forever 
-     :obforever_bind nbind
-     :obforever_res (cold_obforever_binding-lobvar nbind)
-     :obforever_dest nil
-     :obforever_body obody
-     :obforever_epilogue epilo
-     )
-    ))
-
-
-;;;;
-(defmethod compile_obj ((cod prog_exit) env)
-  (let* ( (ebind (prog_exit-exit_bind cod))
-	  (ebody (prog_exit-exit_body cod))
-	  (lvar (cold_any_binding-bname ebind))
-	  (nbind (cold_find_binding lvar env))
-	  (nbody (mapcar (lambda (i) (compile_obj i env)) ebody))
-	  (lasti (last nbody))
-	  )
-    (or (cold_obforever_binding-p nbind) 
-	(error "bad binding in compile_obj prog_exit ~S" cod))
-    (if (consp lasti) 
-	(let* ( (nobv (cold_obforever_binding-lobvar nbind))
-		(li (first lasti)) 
-		(nli (put_destination li nobv)) )
-	  (if nli 
-	      (setf (car lasti) 
-		    nli))))
-    (make-obj_exit
-     :obxit_bind nbind
-     :obxit_body nbody)
-    ))
-
-;;;; compilation of multicall, using the obj_call
-(defmethod compile_obj ((cod prog_multicall) env)
-  (let ( (pformalist (prog_multicall-multicall_formals cod)) 
-	 (pcall (prog_multicall-multicall_call cod))
-	 (pbody (prog_multicall-multicall_body cod)) 
-	 (newenv (cold_fresh_env env))
-	 (revinstrseq nil)
-	 (revresultvars nil)
-	 ) 
-    (assert (or (prog_apply-p pcall) (prog_send-p pcall)))
-    (flet ( 
-	   (handleformalbind 
-	    (bnd)
-	    (let ( (bname (cold_any_binding-bname bnd))
-		   (btype (cold_typed_binding-type bnd))
-		   )
-	      (case btype
-		    (:value 
-		     (let ( (vvar 
-			     (newobjptrvar (compilation-currout this_compilation) bnd 
-					   "multicall value"
-					   )) )
-		       (cold_put_binding 
-			(make-cold_value_binding :bname bname :val vvar :type btype) 
-			newenv)
-		       (push (build_obj_compute vvar (list "(void*)0") btype) 
-			     revinstrseq)
-		       (push vvar revresultvars)
-		       ))
-		    (:long
-		     (let ( (nvar 
-			     (newobjlongvar (compilation-currout this_compilation) bnd 
-					    "multicall long"
-					 )) )
-		       (cold_put_binding
-			(make-cold_value_binding :bname bname :val nvar :type btype)
-			newenv)
-		       (push (build_obj_compute nvar (list "0L") btype) 
-			     revinstrseq)
-		       (push nvar revresultvars)
-		       ))
-		    (otherwise (error "compile_obj prog_multicall unexpected bnd ~S"
-				      bnd))))
-	    ))
-	  (mapc (function handleformalbind) pformalist)
-	  )
-    (let* ( (resultvars (reverse revresultvars)) 
-	    )
-      (cond
-       ( (prog_apply-p pcall)
-	 (push (make-obj_call 
-		:dest (first resultvars)
-		:clos (compile_obj (prog_apply-appl_fun pcall) env)
-		:xtraresults (rest resultvars)
-		:args (mapcar (lambda (e) (compile_obj e env))
-			      (prog_apply-appl_args pcall))
-		) revinstrseq))
-       ( (prog_send-p pcall)
-	 (push (make-obj_send
-		:obs_dest (first resultvars)
-		:obs_sel (compile_obj (prog_send-send_sel pcall) env)
-		:obs_recv (compile_obj (prog_send-send_recv pcall) env)
-		:obs_args   (mapcar (lambda (e) (compile_obj e env))
-				    (prog_send-send_args pcall))
-		:obs_xtraresults (rest resultvars)
-		) revinstrseq))
-       ( t
-	 (error "unexpected call ~S in multicall" pcall))
-       )
-      )
-    (mapc (lambda (e) (push (compile_obj e newenv) revinstrseq)) pbody)
-    (make-obj_block
-     :instrs (reverse revinstrseq))
-    ))
-
-;;;;;;;;;;;;;;;;;;; compilation of toplev definitions
-
-(defmethod compile_obj ((cod prog_defun) env)
-  (push cod (compilation-functions this_compilation))
-  ;; (format *error-output* "compile_obj prog_defun cod <ici> ~S~%" cod)
-  (let* (
-	 ;; if the defun originated from a lambda, we do not need to
-	 ;; build a dataclosure
-	 (slambda (prog_defun-fun_lambda cod))
-	 (orout (make-obj_routine 
-		 :pfun cod 
-		 :nbptr 1 		;reserve slot for result ptr
-		 :nbnum 0 
-		 :nbdouble 0 
-		 :nbcstring 0
-		 :obody nil
-		 :syname  (prog_def-def_name cod)
-		 :rank (length  (compilation-functions this_compilation))
-		 :data2ptrhash (make-hash-table :size 31)
-		 )) 
-	 (odatarout (add_cdata (make-obj_dataroutine
-				:comname (prog_def-def_name cod)
-				:discr 'DISCR_ROUTINE
-				:rout orout
-				)
-			       "defun datarout"
-			       ))
-	 (funbind (and 
-		   (null slambda)
-		   (cold_find_binding  (prog_def-def_name cod) env)
-		   ))
-	 (odatacl (and 
-		   (null slambda)
-		   (cold_function_binding-p funbind)
-		   (let ( (ofunclo (cold_function_binding-fclodata funbind)) )
-		     (assert (obj_dataclosure-p ofunclo))
-		     (setf (obj_dataclosure-rout ofunclo) orout)
-		     (setf (obj_dataclosure-discr ofunclo) 'DISCR_CLOSURE)
-		     (add_cdata ofunclo "defun dataclo")
-		     )))
-	 (oarginsrev nil)
-	 (fbind (prog_defun-fun_argbindings cod)) 
-	 (newenv (cold_fresh_env env))
-	 (oldcurrout (compilation-currout this_compilation))
-	 )
-    (setf (obj_routine-dataclos orout) odatacl)
-    (setf (obj_routine-datarout orout) odatarout)
-    (setf (compilation-currout this_compilation) orout)
-    ;; bind the name to the dataclosure if available
-    (if odatacl 
-	(cold_put_binding 
-	 (make-cold_value_binding  :bname  (prog_def-def_name cod) 
-				   :val odatacl :type ':value)
-	 env))
-    (cold_delay
-     (format nil "compilobj defun ~S closvar"  (prog_def-def_name cod))
-     (if odatacl 
-	 (setf (obj_dataclosure-clodata odatacl)
-	       (mapcar (lambda (var) (handleclosvar var env)) 
-		       (prog_defun-fun_closvars cod))))
-     (mapcar (lambda (var) 
-	       (push 
-		(handleclosvar var env)
-		(obj_dataroutine-roudata odatarout)
-		)) 
-	     (prog_defun-fun_constants cod)))
-    (labels
-     ( (bindvar (nam val type) 
-		(let ( (nbi (make-cold_value_binding 
-			     :bname nam :val val :type type))) 
-		  (cold_put_binding nbi newenv
-				    )))
-       ( doptr (b) 			;add a value arg
-	       (let ( (ovar (newobjptrvar orout b
-					  "defun doptr"
-					  )) )
-		 (bindvar (cold_formal_binding-bname b) ovar ':value)
-		 (push (make-obj_getptrarg_instr
-			:dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
-		 ) )
-       ( dolong (b) 			;add a numerical arg
-		(let ( (ovar (newobjlongvar orout b  
-					    "defun dolong"
-					 )) )
-		  (bindvar (cold_formal_binding-bname b) ovar ':long)
-		  (push (make-obj_getlongarg_instr 
-			 :dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
-		  ) )
-       ( do_cstring (b) 			;add a constant cstring arg
-		(let ( (ovar (newobjcstringvar orout b  
-					    "defun do_cstring"
-					 )) )
-		  (bindvar (cold_formal_binding-bname b) ovar ':cstring)
-		  (push (make-obj_getcstringarg_instr 
-			 :dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
-		  ) )
-       ( doit (b)			;handle by dispatching
-	      (case (cold_formal_binding-type b)
-		    (:value (doptr b))
-		    (:long (dolong b))
-		    (:cstring (do_cstring b))
-		    (otherwise (error "compile_obj progdefun unexpected binding ~s" b)))
-	      )
-       (comp1 (i)			;compile 1 instruction
-	      (compile_obj i newenv)
-	      )
-       (comp (i)			;compile 1 or many instr
-	     (if (listp i) (mapcar #'comp1 i) (comp1 i))
-	     )
-       )
-     (mapcar (function doit) fbind)
-     (let* ( (funbody (prog_defun-fun_body cod)) ;compile the entire body
-	     (objbody (comp funbody)) 
-	     (insarg (make-obj_get_arguments :instrs (reverse oarginsrev))) )
-;;; put the proper list of instructions
-       (setf (obj_routine-obody orout)
-	     (if (listp objbody) (cons insarg objbody) (list insarg objbody)))
-;;; restore compilation & return the routine
-       (setf (compilation-currout this_compilation) oldcurrout)
-       orout
-       ))))
-
-
-;;;; compilation of a primitive
-(defmethod compile_obj ((cod prog_defprimitive) env)
-  ;; create an object with 3 fields: the name, the formal tuple, the expansion tuple
-  (let* 
-      (
-       (pname (prog_def-def_name cod))
-       (pformals (prog_defprimitive-primitive_formals cod))
-       (ptype (prog_defprimitive-primitive_type cod))
-       (pexpand (prog_defprimitive-primitive_expansion cod))
-       (onamestr (add_cdata (make-obj_datastring
-			     :comname pname
-			     :discr 'DISCR_STRING 
-			     :string (string pname))
-			    "defprimit namstr"
-			    ))
-       (oformals 
-	(mapcar 
-	 (lambda (forbi)
-	   (add_cdata (make-obj_datainstance
-		       :comname pname
-		       :discr 'CLASS_FORMAL_BINDING
-		       :slots (list 
-			       (get_obj_symbol (cold_formal_binding-bname forbi) "defprimi forbi")
-			       (get_obj_type (cold_formal_binding-type forbi)))
-		       )
-		      "defprimit formal"
-		      ))
-	 pformals))
-       (oexptuple 
-	(add_cdata 
-	 (make-obj_datamultiple
-	  :comname pname
-	  :discr 'DISCR_MULTIPLE
-	  :values 
-	  (mapcar 
-	   (lambda (e)
-	     (cond 
-	      ((symbolp e)
-		    (let ((po (position-if
-			       (lambda (bi) (eq (cold_formal_binding-bname bi) e))
-			       pformals)))
-		      (or po 
-			  (error "unexpected symbol ~S in defprimitive ~S" e cod))
-		      (nth po oformals)
-		      )
-		    )
-	      ((stringp e)
-	       (add_cdata (make-obj_datastring
-			   :comname pname
-			   :discr 'DISCR_STRING 
-			   :string e)
-			  "defprimit string"
-			  ))
-	      (t (error "unexpected stuff ~S in defprimitive ~S" e cod))
-	      ))
-	     pexpand))
-	 "defprimit exptuple"
-	 ))
-       (oformaltuple
-	(add_cdata
-	 (make-obj_datamultiple
-	  :comname (prog_def-def_name cod)
-	  :discr 'DISCR_MULTIPLE
-	  :values oformals)
-	 "defprimit formtuple"
-	 ))
-       (oprim (add_cdata (make-obj_datainstance 
-			  :comname pname
-			  :discr 'CLASS_PRIMITIVE
-			  :slots (list nil onamestr oformaltuple oexptuple))
-			 "defprimit oprim"
-			 )
-	      )
-       )
-    nil
-    ))
-
-
-
-
-;; recursive ancestors in reversed order
-(defun revancestors_defclass (dc)
-  (if dc 
-      (let 
-	  ((supdc (prog_defclass-class_super dc)))
-	(if supdc (cons supdc (revancestors_defclass supdc))))))
-
-;; recursive fields in reversed order
-(defun revfields_defclass (dc)
-  (if dc 
-      (let ((supdc (prog_defclass-class_super dc)))
-	(revappend (prog_defclass-class_ownfields dc) (revfields_defclass supdc)))))
-
-
-;;;;; compilation of a defclass
-(defmethod compile_obj ((cod prog_defclass) env)
-  (let (
-	(pname (prog_def-def_name cod))
-	(ppredef (prog_predef-predef_rank cod))
-	(allfields (reverse (revfields_defclass cod)))
-	(allancestors (reverse (revancestors_defclass cod)))
-	)
-    (let* (
-	   (obstrname (add_cdata 
-		       (make-obj_datastring
-			:comname pname
-			:discr 'DISCR_STRING :string (string pname))
-		       "defclass strname"
-		       )) 
-	   (obclass (add_cdata 
-		     (make-obj_datainstance 
-		      :comname pname
-		      :discr 'CLASS_CLASS
-		      :predef ppredef
-		      :objnum 'OBMAG_OBJECT)
-		     "defclass obclass"
-		     ))
-	   (clabind (cold_find_binding (prog_defclass-def_name cod) env))
-	   (obancestorstuple 
-	    (add_cdata 
-	     (make-obj_datamultiple
-	      :comname (prog_def-def_name cod)
-	      :discr 'DISCR_SEQCLASS
-	      :values 
-	      (mapcar
-	       (lambda (anc) 
-		 (assert (prog_defclass-p anc))
-		 (let* ( (ancbind (cold_find_binding 
-				   (prog_defclass-def_name anc) env))
-			 (ancdata (cold_class_binding-classdata ancbind))
-			 )
-		   ancdata
-		   ))
-	       allancestors)
-	      )
-	     "defclass seqancestors"
-	     ))
-	   (obsuper 
-	    (if allancestors
-		(let* (
-		       (anc (first (last allancestors)))
-		       (ancbind (cold_find_binding 
-				 (prog_defclass-def_name anc) env))
-		       (ancdata (cold_class_binding-classdata ancbind))
-		       )
-		  ancdata
-		  )))
-	   (obfieldstuple 
-	    (add_cdata 
-	     (make-obj_datamultiple
-	      :comname (prog_def-def_name cod)
-	      :discr 'DISCR_SEQFIELD
-	      :values  
-	      (mapcar
-	       (lambda (f) 
-		 (assert (prog_field-p f))
-		 (let ( (fldata
-			 (add_cdata 
-			  (make-obj_datainstance 
-			   :comname (prog_field-def_name f)
-			   :discr 'CLASS_FIELD
-			   :objnum (prog_field-field_offset f)
-			   :slots
-			   (list nil 
-				 (add_cdata 
-				  (make-obj_datastring
-				   :comname (prog_def-def_name f)
-				   :discr 'DISCR_STRING
-				   :string (string (prog_def-def_name f))))
-				 nil))))
-			(flbind
-			 (cold_find_binding (prog_field-def_name f) env))
-			)
-		   (assert (cold_field_binding-p flbind))
-		   (setf (cold_field_binding-fieldata flbind) fldata)
-		   )
-		 )
-	       allfields)
-	      )
-	     "defclass fieldtupl"
-	     ))
-	   )
-      (setf (cold_class_binding-classdata clabind) obclass)
-      (setf (obj_datainstance-slots obclass) 
-	    (list 
-	     nil			;no prop
-	     obstrname
-	     nil			;no methodict
-	     nil 			;no sendclosure
-	     obsuper			;disc_super
-	     obancestorstuple
-	     obfieldstuple
-	     nil			;no objnumdescr
-	     nil			;nod classdata
-	     ))
-      nil				;result of compile_obj
-      )))
-
-
-;;; compile a definstance (not a defselector!)
-(defmethod compile_obj ((cod prog_definstance) env)
-  (let ( (iname (prog_def-def_name cod))
-	 (ipredef (prog_predef-predef_rank cod))
-	 (iclass (prog_definstance-inst_class cod))
-	 (iobjnum (prog_definstance-inst_objnum cod))
-	 (islots (prog_definstance-inst_slots cod)) )
-    (assert (prog_defclass-p iclass))
-    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
-	   (insbind (cold_find_binding iname env))
-	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
-	   )
-      (assert (cold_instance_binding-p insbind))
-      (assert (cold_class_binding-p clabind))
-      (assert (cold_class_binding-classdata clabind))
-      (let ( (ob
-	      (make-obj_datainstance 
-	       :comname (prog_def-def_name cod)
-	       :discr (cold_class_binding-classdata clabind)
-	       :objnum 
-	       ;;special hack for OBMAG_* names or others
-	       (if (symbolp iobjnum) iobjnum
-		 (compile_obj iobjnum env))
-	       :predef ipredef))
-	     ) 
-	(add_cdata ob "definstance ob")
-	(setf (cold_instance_binding-instancedata insbind) ob)
-	;; fill the slot, should be here to allow
-	;; a slot to refer to the newly made
-	;; instance
-	(mapc (lambda (s)
-		(setf (aref slovec 
-			    (prog_field-field_offset (instance_slot-slot_field s)) )
-		      (let* ( (cobs 
-			       (compile_obj (instance_slot-slot_value s) env)) 
-			      ;; we put the tempslot variable as destination
-			      (pobs
-			       (put_destination cobs cold_tempslot_var))
-			      )
-			(or pobs cobs)
-			)))
-	      islots)
-	(setf (obj_datainstance-slots ob)
-	      (concatenate 'list slovec)) ;; convert slovec to a list
-	ob
-	)
-      )
-    nil))
-
-;;; compile a defselector is quite similar to a definstance
-(defmethod compile_obj ((cod prog_defselector) env)
-  (let ( (iname (prog_def-def_name cod))
-	 (ipredef (prog_predef-predef_rank cod))
-	 (iclass (prog_definstance-inst_class cod))
-	 (iobjnum (prog_definstance-inst_objnum cod))
-	 (islots (prog_definstance-inst_slots cod)) )
-    (assert (prog_defclass-p iclass))
-    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
-	   (insbind (cold_find_binding iname env))
-	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
-	   )
-      (assert (cold_selector_binding-p insbind))
-      (assert (cold_class_binding-p clabind))
-      (assert (cold_class_binding-classdata clabind))
-      (let* ( 
-	     (onamestr (add_cdata (make-obj_datastring
-				   :comname iname
-				   :discr 'DISCR_STRING 
-				   :string (string iname))
-				  "defselect namstr"
-				  ))
-	     (ob
-	      (make-obj_datainstance 
-	       :comname (prog_def-def_name cod)
-	       :discr (cold_class_binding-classdata clabind)
-	       :objnum 
-	       ;;special hack for OBMAG_* names or others
-	       (if (symbolp iobjnum) iobjnum
-		 (compile_obj iobjnum env))
-	       :predef ipredef))
-	     ) 
-	(add_cdata ob "defselector ob")
-	(setf (cold_selector_binding-selectordata insbind) ob)
-	;; fill the slot, should be here to allow
-	;; a slot to refer to the newly made
-	;; instance
-	(mapc (lambda (s)
-		(setf (aref slovec 
-			    (prog_field-field_offset (instance_slot-slot_field s)) )
-		      (let* ( (cobs 
-			       (compile_obj (instance_slot-slot_value s) env)) 
-			      ;; we put the tempslot variable as destination
-			      (pobs
-			       (put_destination cobs cold_tempslot_var))
-			      )
-			(or pobs cobs)
-			)))
-	      islots)
-	;; put into the 2nd = rank1 (for :named_name field) position the onamestr
-	(setf (aref slovec 1) onamestr)
-	(setf (obj_datainstance-slots ob)
-	      (concatenate 'list slovec)) ;; convert slovec to a list
-	ob
-	)
-      )
-    nil))
-
-
-
-
-;; get (and generate if needed) the objinstance for a symbol
-(defun get_obj_symbol (sym &optional why) 
-  (assert (symbolp sym) (sym) "bad argument to get_obj_symbol ~S" sym)
-  (let ((sydict (compilation-symboldict this_compilation)))
-    (or (gethash sym sydict) 
-	(let* ( 
-	       (onamestr (add_cdata (make-obj_datastring
-				     :comname sym
-				     :discr 'DISCR_STRING 
-				     :string (string sym))
-				    (if why (concatenate 'string "GetObjSymb namstr " why)
-				      "getobjsymb namstr")
-				    ))
-	       (osym (add_cdata (make-obj_datainstance
-				 :discr (if (keywordp sym) 'CLASS_KEYWORD 'CLASS_SYMBOL)
-				 :comname sym
-				 :slots (list nil onamestr nil))
-				(if why (concatenate 'string "GetObjSymb osym " why)
-				  "getobsymb osym")
-				))
-	       )
-	  (setf (gethash sym sydict) osym)
-	  osym
-	  )
-	#|				;
-	(let* ( (odatasym  (make-obj_dataqsymbol :comname sym :qsymb sym)) 
-	(osym (or (currout_data2ptr odatasym) (newobjconst odatasym))) )
-	(setf (gethash sym sydict) osym)
-	osym
-	)
-	|#
-)))
-
-;; translate a type
-(defun get_obj_type (ty)
-  (case ty
-	(:value 'CTYPE_VALUE)
-	(:long 'CTYPE_LONG)
-	(:cstring 'CTYPE_CSTRING)
-	(t (error "bad type to get_obj_type ~S" ty))))
-
-
-
-;;;;;;;;;;;;;;;;;;; compilation of instructions
-(defmethod compile_obj ((cod prog_let) env)
-  (let ( (lbind (prog_let-let_bindings cod))
-	 (lbody (prog_let-let_body cod)) 
-	 (newenv (cold_fresh_env env))
-	 (locptrvars nil)		;list of local pointers vars (to be freed & cleared)
-	 (loclongvars nil)		;list of local long vars (to be freed & cleared)
-	 (revinstrseq nil)
-	 )
-    (labels 
-	( (checkbinding 
-	   (bnd)			; compute the type of each binding if it didn't have one
-	   (assert (cold_let_binding-p bnd))
-	   (if (null (cold_let_binding-type bnd))
-	       (let ( (bexpr (cold_let_binding-expr bnd)) )
-		 (cond ( (prog_primitive-p bexpr) 
-			 (setf (cold_let_binding-type bnd) 
-			       (prog_defprimitive-primitive_type
-				(prog_primitive-prim_oper bexpr)))
-			 )
-		       ( (and (atom bexpr)
-			      (cold_find_binding bexpr env))
-			 (let ( (exbnd (cold_find_binding bexpr env)) )
-			   (and 
-			    (cold_typed_binding-p exbnd)
-			    (cold_typed_binding-type exbnd)
-			    (setf (cold_let_binding-type bnd) 
-				  (cold_typed_binding-type exbnd))
-			    )
-			   )
-			 ))))
-	   ;; by default set the type to :value
-	   (if (null (cold_let_binding-type bnd))
-	       (setf (cold_let_binding-type bnd) ':value))
-	   )
-	  (handlebinding
-	   (bnd)
-	   (let ( (bexpr (cold_let_binding-expr bnd)) 
-		  (btype (cold_typed_binding-type bnd)) 
-		  (bname (cold_any_binding-bname bnd))
-		  )
-	     (case btype
-	       (:value 
-		(let ( (vvar 
-			(newobjptrvar (compilation-currout this_compilation) bnd 
-				      "compilet ptr" )) )
-		  (push vvar locptrvars)
-		  (cold_put_binding 
-		   (make-cold_value_binding :bname bname :val vvar :type btype) 
-		   newenv)
-		  (let ( (compexp  
-			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
-		    (push (or (put_destination compexp vvar) compexp) revinstrseq)
-		    )))
-	       (:long 
-		(let ( (nvar 
-			(newobjlongvar (compilation-currout this_compilation) bnd 
-				       "compilet long")) )
-		  (push nvar loclongvars)
-		  (cold_put_binding
-		   (make-cold_value_binding :bname bname :val nvar :type btype)
-		   newenv)
-		  (let ( (compexp  
-			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
-		    (push (or (put_destination compexp nvar) compexp) revinstrseq)
-		    )))
-	       (:void
-		;; dont use any objvar and dont putdest
-		(cold_put_binding
-		 (make-cold_value_binding :bname bname :val nil :type btype)
-		 newenv)
-		(let ( (compexp  
-			(compile_obj  (cold_let_binding-expr bnd) newenv)) )
-		  (push compexp revinstrseq)
-		  ))
-	       (otherwise (error "compile_obj prog_let unexpected binding ~s" bnd))
-	       )
-	     )
-	   )
-	  (comp1 
-	   (cod)
-	   (push (compile_obj cod newenv) revinstrseq)
-	   )
-	  (comp 
-	   (cod)
-	   (if (listp cod) (mapcar (function comp1) cod) (comp1 cod)))
-	  )
-      (mapc (function checkbinding) lbind)
-      (mapc (function handlebinding) lbind)
-      (comp lbody)
-      (let ( (lbc (first revinstrseq)) );; lbc is the last body compiled ...
-       ;;; generates clears only if the compiled body is a variable
-       ;;; which we don't clear
-	(mapcar (lambda (pv) 
-		  (if (and (obj_var-p lbc) (not (eql lbc pv)))
-		      (push (make-obj_clearptr :clrptrvar pv) revinstrseq))
-		  (freeobjptrvar pv)
-		  ) locptrvars)
-	(mapcar (lambda (lv)
-		  (if (and (obj_var-p lbc) (not (eql lbc lv)))
-		      (push (make-obj_clearlong :clrlongvar lv) revinstrseq))
-		  (freeobjlongvar lv)
-		  ) loclongvars)
-	;;; push again the lbc to make it the result of the block
-	(if (obj_var-p lbc)
-	    (push lbc revinstrseq))))
-    (make-obj_block :instrs (reverse revinstrseq))
-    )
-  )
-
-(defmethod compile_obj ((cod prog_primitive) env)
-  (error "unexpected call to compile_obj prog_primitive cod ~S env ~S" cod env)
-  )
-
-(defmethod compile_obj ((cod prog_chunk) env)
-  (let* ( (chargs (prog_chunk-chunk_args cod)) 
-	  (objc (build_obj_compute 
-		 nil
-		 (mapcar (lambda (a)
-			   (cond ((stringp a) (make-obj_verbatim :vstr a))
-				 ((numberp a) a)
-				 (t (compile_obj a env)))
-			   )
-			 chargs)
-		 (prog_chunk-chunk_type cod)
-		 )) )
-    objc
-    ))
-
-
-(defmethod compile_obj ((cod prog_unsafe_get_field) env)
-  (let* ( (ugfield (prog_unsafe_get_field-uget_field cod))
-	  (ugobj (prog_unsafe_get_field-uget_obj cod)) )
-    (assert (prog_field-p ugfield))
-    (build_obj_compute
-     nil
-     (list "/*unsafe_get*/ (basilys_field_object(("
-	   (compile_obj ugobj env)
-	   "), ("
-	   (prog_field-field_offset ugfield)
-	   "))"
-	   (format nil "/**.~a.**/" (prog_field-def_name ugfield))
-	   ")"
-	   )
-     :value
-     )))
-
-
-(defmethod  compile_obj ((cod prog_unsafe_put_fields) env)
-  (let* ( (upobj (prog_unsafe_put_fields-uput_obj cod))
-	  (upkeys (prog_unsafe_put_fields-uput_keys cod))
-	  (revinstrs nil) )
-    ;; push the destination in a register
-    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register basilysobject_ptr_t obdest= 0;")
-	  revinstrs)
-    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register int oblen= 0;")
-	  revinstrs)
-    (push 
-     (build_obj_compute
-      nil
-      (list "/*unsafe_put setdest*/ obdest = (void*)"
-	    (compile_obj upobj env))
-      :value
-      )
-     revinstrs)
-    (push (make-obj_verbatiminstr :vstr "gcc_assert(basilys_magic_discr(obdest) == OBMAG_OBJECT);")
-	  revinstrs)
-    (push (make-obj_verbatiminstr :vstr "oblen = basilys_object_length(obdest);")
-	  revinstrs)
-    (let ( (maxfldoff 0) )
-      (loop
-       for curkpair in upkeys do
-       (let ( (curfld (car curkpair))
-	      (curexp (cdr curkpair))
-	      )
-	 (assert (prog_field-p curfld))
-	 (setq maxfldoff (max maxfldoff (prog_field-field_offset curfld)))
-       ))
-    (push (make-obj_verbatiminstr :vstr (format nil "gcc_assert(oblen > ~d);" maxfldoff))
-	  revinstrs)
-      )
-    ;; push the field initializations
-    (mapc 
-     (lambda (curkpair)
-       (let ( (curfld (car curkpair))
-	      (curexp (cdr curkpair))
-	      )
-	 (assert (prog_field-p curfld))
-	 (push
-	  (build_obj_compute
-	   nil
-	   (list
-	    "/*unsafe_put field*/ basilys_checked_assign(obdest->obj_vartab["
-	    (prog_field-field_offset curfld)
-	    "] "
-	    (format nil "/**.~a.**/" (prog_field-def_name curfld))
-	    " = (basilys_ptr_t)(" 
-	    (compile_obj curexp env)
-	    "))"
-	    )
-	   :value
-	   )
-	  revinstrs)
-	 ))
-     upkeys)
-    ;; push the touch of the destination
-    (push
-     (build_obj_compute 
-      nil
-      (list "/*unsafe_put touch*/ basilysgc_touch(obdest)")
-      :void
-      )
-     revinstrs)
-    ;; push the destination itself as the result
-    (push
-     (compile_obj upobj env)
-     revinstrs)
-    ;; return the block
-    (make-obj_block :instrs (reverse revinstrs))
-    ))
-
-
-(defmethod compile_obj ((cod prog_make_instance) env)
-  (let ( (classv (prog_make_instance-mki_class cod)) 
-	 (mikeys (prog_make_instance-mki_keys cod)) 
-	 (classd (prog_make_instance-mki_classdef cod))
-	 (revinstrs nil)
-	 )
-    ;; push the destination in a register
-    (push (make-obj_verbatiminstr :vstr "/*makeinst*/register basilysobject_ptr_t obnew= 0;")
-	  revinstrs)
-    (let ( (compclass (compile_obj classv env)) 
-	   (siznew  (length (prog_defclass-class_allfields classd)))
-	   )
-      (if (and (compilation-currout this_compilation)
-	       (obj_data-p compclass))
-	  (setq compclass (newobjconst compclass "makeinst class")))
-					;      (warn "compile_obj make_instance cod ~S compclass ~S env ~S ~%...compilobj make_inst currout ~S" 
-					;	     cod compclass env (compilation-currout this_compilation))
-      (push 
-       (build_obj_compute
-	nil
-	(list "/*make_instance*/obnew = basilysgc_new_raw_object( (void*)"
-	      compclass
-	      "," 
-	      siznew
-	      ")")
-	:value
-	)
-       revinstrs)
-      ;; push the field initializations
-      (mapc 
-       (lambda (curkpair)
-	 (let ( (curfld (car curkpair))
-		(curexp (cdr curkpair))
-		)
-	   (assert (prog_field-p curfld))
-	   (assert (< (prog_field-field_offset curfld) siznew))
-	   (push
-	    (build_obj_compute
-	     nil
-	     (list
-	      "/*make_inst field*/ basilys_checked_assign(obnew->obj_vartab["
-	      (prog_field-field_offset curfld)
-	      "] "
-	      (format nil "/**.~a.**/" (prog_field-def_name curfld))
-	      " = (basilys_ptr_t)(" 
-	      (compile_obj curexp env)
-	      "))"
-	      )
-	     :value
-	     )
-	    revinstrs)
-	   ))
-       mikeys)
-      )
-    ;; push the new object itself as the result
-    (push
-     (make-obj_verbatim :vstr "obnew")
-     revinstrs)
-    ;; return the block
-    (make-obj_block :instrs (reverse revinstrs))
-    ))
-
-
-(defun compile_argobj (cod env)
-;;@@@@ STRING ARGUMENTS ARE HANDLED HERE
-;;- (if (stringp cod) 
-;;-     (let*  ( (obstrdata 
-;;-		(add_cdata (make-obj_datastring
-;;-			    :comname cod
-;;-			    :discr 'DISCR_STRING
-;;-			    :string cod)
-;;-			   "argobj strdata")
-;;-		) 
-;;-	       (constri (newobjconst obstrdata "argobj constri")) 
-;;-	       )
-;;-	;;; (warn "compile_argobj cod ~S obstrdata ~S constr ~S env ~S~%" cod obstrdata constri env)
-;;-	constri) 
-   (compile_obj cod env)
-  )
-;;- )
-
-
-(defmethod compile_obj ((cod prog_apply) env)
-  (let ( (apfun (prog_apply-appl_fun cod))
-	 (apargs (prog_apply-appl_args cod)) )
-    (make-obj_call
-     :clos (compile_obj apfun env)
-     :args (mapcar (lambda (c) (compile_argobj c env)) apargs)
-     )
-    )
-)
-
-(defmethod compile_obj ((cod prog_send) env)
-  (let ( (isel (prog_send-send_sel cod))
-	 (irecv (prog_send-send_recv cod))
-	 (iargs (prog_send-send_args cod)) )
-    (make-obj_send
-     :obs_dest nil
-     :obs_sel (compile_obj isel env)
-     :obs_xtraresults nil
-     :obs_recv (compile_obj irecv env)
-     :obs_args  (mapcar (lambda (c) (compile_argobj c env)) iargs)
-     )
-))
-
-
-
-
-(defmethod compile_obj ((cod prog_lambda) env)
-  (error "should never be called compile_obj prog_lambda cod=~S ~%" cod)
-)
-
-
-(defmethod compile_obj ((cod prog_makeclosure) env)
-  (flet 
-      ( (comp (c) (compile_obj c env)) )
-    (let* 
-	( (cfun (prog_makeclosure-mkclos_fun cod)) 
-	  (cvars (prog_makeclosure-mkclos_closvars cod))
-	  (mkc
-	   (make-obj_mkclosure 
-	    :cfun cfun
-	    :cvals (mapcar (function comp) cvars)
-	    ) 
-	   )
-	  )
-      (let ((obr 
-	     (find-if 
-	      (lambda (o) 
-		(and (obj_dataroutine-p o)
-		     (eq (obj_routine-pfun (obj_dataroutine-rout o)) cfun)))
-	      (compilation-cdata this_compilation))))
-	(or obr (error "compile_obj makeclosure ~S ~%..cannot find dataroutine for ~S"
-		       cod cfun))
-	(setf (obj_mkclosure-kobjrout mkc) (newobjconst obr "makeclos objro"))
-	mkc
-	))))
-
-
-
-(defmethod compile_obj ((cod prog_return) env)
-  (let ( (progrets (prog_return-retexprs cod)) )
-    (or (listp progrets) (error "bad prog_return without list return ~s" cod))
-    (let ( (compexprs (mapcar (lambda (c) (compile_obj c env)) progrets)) )
-      (let ( (retmain (and (consp compexprs) (first compexprs))) 
-	     (retextras (and (consp compexprs)  (rest compexprs))) )
-	(and (prog_src-p retmain) (not (eq (query_ctype retmain) :value))
-	     (error "prog_return has bad main value ~s" cod))
-	(if retmain
-	    (progn
-;	      (warn "compilobjreturn retmain ~S retextras ~S~%" retmain retextras)
-	      (let ( (newretmain (put_destination retmain cold_return_var)) )
-	      (if newretmain (setq retmain newretmain)))))
-	(make-obj_return
-	 :mainreturn retmain
-	 :extrareturns retextras)
-   )
-)))
-
-
-(defmethod compile_obj ((cod prog_setq) env)
-  (let* ( (pva (prog_setq-setq_var cod))
-	  (pex (prog_setq-setq_expr cod)) 
-	  (cva (compile_obj pva env))
-	  (cex (compile_obj pex env))
-	  (typcva (query_ctype cva))
-	  (typcex (query_ctype cex))
-	  )
-    (and typcva typcex 
-	 (or (eq typcva typcex)
-	     (error "setq incompatible type cod ~S~%.. cva ~S~%.. cex ~S~%" cod cva cex)))
-    (if (consp cex) (error "setq multi-expr cod ~S cex ~S" cod cex))
-    (if (obj_var-p cva)
-	(build_obj_compute
-	 cva
-	 (if (listp cex) cex (list cex))
-	 typcex
-	 )
-      (make-obj_closetq
-       :cldest cva
-       :val cex)
-      )))
-
-
-(defmethod compile_obj ((cod prog_if) env)
-  (let ( (pcond (prog_if-cond_expr cod))
-	 (pthen (prog_if-then_expr cod)) 
-	 (pelse (prog_if-else_expr cod)) )
-    (let ( (ocond (compile_obj pcond env))
-	   (othen (and pthen (compile_obj pthen env)))
-	   (oelse (and pelse (compile_obj pelse env))) )
-      (if (and othen oelse) 
-	  (let ( (thenctype (if othen (or (query_ctype othen) :value)))
-		 (elsectype (if oelse (or (query_ctype oelse) :value))) )
-	    (or 
-	     (eq thenctype elsectype)
-	     (eq thenctype ':void)
-	     (eq elsectype ':void)
-	     (warn "if incompatible type cod ~S~%.. othen ~S~%... thenctype ~S ~%.. oelse ~S~%... elsectype ~S~%"
-		   cod othen  thenctype oelse elsectype))))
-      (make-obj_if
-       :ob_cond ocond
-       :ob_then othen
-       :ob_else oelse
-       )
-      )))
-
-
-
-
-;;;;;;;;;;;;; parsing a source file
-(defun ctime ()
-  (multiple-value-bind
-   (second minute hour date month year day-of-week dst-p tz)
-   (get-decoded-time)
-   (format nil "~4,'0d ~a ~2,'0d @ ~2,'0d:~2,'0d:~2,'0d (GMT~@d)"
-	   year (nth month '("???" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
-			     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
-	   date hour minute second tz))
-)
-
-
-(defun compile_toplev (cod freshenv)
-  ;; if it is a definition, compile it
-  (if (prog_def-p cod)
-      (progn
-;	(format *error-output* "compile_toplev def cod=~S" cod)
-	(let ( (ce (compile_obj cod freshenv)) )
-;	  (format  *error-output* "compile_toplev def ce=~S" cod)
-	  (if ce (add_objcode ce))
-	  )
-	)
-    ;; not a definition, compile it appropriately and add it to the
-    ;; initial routine's body
-    (let* ( 
-	   (oldcurrout (compilation-currout this_compilation))
-	   (initrout (compilation-initrout this_compilation))
-	   (initbody (obj_routine-obody initrout))
-	   )
-      (setf (compilation-currout this_compilation) initrout)
-;      (format *error-output* "compile_toplev avant compile_obj cod=~S~%" cod)
-      (let ( (ce (compile_obj cod freshenv)) )
-;	(format *error-output* "compile_toplev apres compile_obj cod=~S ce=~S~%" cod ce)
-	(if ce (setf (obj_routine-obody initrout)
-		     (append initbody (list ce))))
-	)
-      (setf (compilation-currout this_compilation) oldcurrout)
-      )))
-
-
-;; limit the CPU time to 1000 sec on Clisp
-;; sometimes a clisp.run process remains.... eg when killing xemacs...
-#+CLISP
-(setf (posix:rlimit :cpu) (values 1000 1200))
-
-
-;; first argument is mandatory MELT/basilys source, second argument
-;; may be the generated C file
-(defun handle-source-file (filename &optional outnamearg)
-  (with-open-file
-   (istr filename)
-   (format *error-output* "reading file ~s ~%" filename)
-   (let ( (*readtable* (copy-readtable)) 
-	  (readrevseq nil)
-	  (outpathname (if (stringp outnamearg) outnamearg 
-			 (make-pathname :name (pathname-name filename) :type "c")))
-	  )
-     (loop 
-      (let ((rditem (read istr nil)))
-	(if (null rditem)
-	    (return)
-	  (push rditem readrevseq) 
-	  )
-	)
-      )
-     (let* ( (readseq (reverse readrevseq)) 
-	     (initrout (make-obj_initroutine 
-			:nbptr 3
-			:nbnum 1
-			:nbdouble 0
-			:pfun 'init	
-			:data2ptrhash (make-hash-table :size 281)
-			:inirou_datarankdict  (make-hash-table :size 281)
-			)) 
-	     (thiscompil (make-compilation 
-			  :symboldict (make-hash-table)
-			  :initrout initrout
-			  )) 
-	     ) 
-       (setq this_compilation thiscompil)
-       (with-open-file
-	(outstr outpathname :direction :output :if-exists :rename)
-	(format outstr "/* generated file ~a on ~a */~%#include \"run-basilys.h\"~%" outpathname (ctime))
-	(format outstr "#define COLD_EXTRAGAP 2 /*the cold generator is buggy so need the gap */~%")
-	(format outstr "/*** read ~d inputs ***/ ~%~%" (length readseq)) 
-	(loop
-	 for rk from 1
-	 for curinp in readseq
-	 do 
-	 (format_c_comment outstr "++ input #~d~%~S~% ++~%~%" rk curinp))
-;	(finish-output outstr)
-	(format *error-output* "read ~d items from file ~s ~%" 
-		(length readseq) filename)
-	(let (  (freshenv  (cold_fresh_env cold_first_env))
-		)
-	  (labels 
-	   ( (expand-task 
-	      (inp)
-					; (cold_run_delayed_tasks "start expandtask")
-	      (let* ( 
-		     (exp (cold_macroexpand inp freshenv)) )
-		(cold_delay "normalize after expand" (normalize-task exp)))
-	      ; (cold_run_delayed_tasks "end expandtask")
-	      )
-	     (normalize-task 
-	      (exp)
-					; (cold_run_delayed_tasks "start normalizetask")
-;	      (format *error-output* "stuff to normalize exp=~S of type ~S~%" 
-;		      exp (type-of exp))
-	      (let ( (normexp (normalize_toplev exp freshenv)) )
-		(cold_delay "compile after normalize" (compile-task normexp))
-		)
-	      (cold_run_delayed_tasks "end normalizetask")
-	      )
-	     (compile-task
-	      (cod)
-					; (cold_run_delayed_tasks "start compiletask")
-;	      (finish-output outstr)
-	      (compile_toplev cod freshenv)
-	      (cold_run_delayed_tasks "end compiletask")
-	      )
-	     )
-	   (mapc (lambda (inp) (cold_delay "initial expand" (expand-task inp))) readseq)
-	   )				;end of labels
-	  (cold_run_delayed_tasks "initial")
-					; output the declarations
-	  (format *error-output* ";before writing ~d declarations ~g cpusec~%" 
-		  (length (compilation-revobjcode this_compilation))
-		  (cpusec))
-	  (loop
-	   for rk from 1
-	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
-	   do
-	   (format outstr "~%~%/*** declobj #~d ***/~%" rk)
-	   (output_cdecl ob outstr)
-	   ) 
-	  (cold_run_delayed_tasks "after decl")
-					; output the bodies
-	  (format *error-output* ";before writing ~d bodies ~g cpusecs~%" 
-		  (length (compilation-revobjcode this_compilation)) (cpusec))
-	  (loop
-	   for rk from 1
-	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
-	   do
-	   (if (zerop (rem rk 32))
-	       (format *error-output* ";;writing body #~d of ~a : ~g cpusecs~%"
-		       rk (obj_routine-syname ob) (cpusec)))
-	   (format outstr "~%~%~%/*** obj #~d ***/~%" rk)
-	   (output_ccode ob outstr)
-;	   (finish-output outstr)
-	   )
-	  (cold_run_delayed_tasks "after bodies")
-	  (finish-output outstr)
-	  (format *error-output* ";before writing start routine ~g cpusecs~%" (cpusec))
-	  (cold_run_delayed_tasks "after initrout preparation")
-	  (format outstr "~%~%/*** initial routine is ***/~%")
-	  (output_cdecl initrout outstr)
-	  (finish-output outstr)
-	  (output_ccode initrout outstr)
-;	  (finish-output outstr)
-	  )
-	(format outstr "~%~%/*** end of generated file ~a ***/~%~%" outpathname)
-	(finish-output outstr)
-	)
-       (format *error-output* ";end of generation of ~S in ~g cpusecs~%" 
-	       outpathname (cpusec))
-       (finish-output *error-output*)
-       ))))
-
-(setq *print-circle*  t)
-
-
-;; eof $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $