added most of my (Basile Starynkevitch's) files

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

22 files changed, 17737 insertions, 12 deletions

diff --git a/contrib/cold-basilys.lisp b/contrib/cold-basilys.lisp
new file mode 100644
index 00000000000..1c07310b8bf
--- /dev/null
+++ b/contrib/cold-basilys.lisp
@@ -0,0 +1,5422 @@
+;; file cold-basilys.lisp
+;; -*- Lisp -*-
+;; $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;    Copyright 2008 Free Software Foundation, Inc.
+;;    Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+
+;;    This file is part of GCC.
+
+;;    GCC is free software; you can redistribute it and/or modify
+;;    it under the terms of the GNU General Public License as published by
+;;    the Free Software Foundation; either version 3, or (at your option)
+;;    any later version.
+
+;;    GCC is distributed in the hope that it will be useful,
+;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;    GNU General Public License for more details.
+
+;;    You should have received a copy of the GNU General Public License
+;;    along with GCC; see the file COPYING3.  If not, write to
+;;    the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+;;    Boston, MA 02110-1301, USA.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; conventionally, our names contain underscores _ so the minus sign -
+;; is only in CommonLisp names, in particular in names generated by
+;; defstruct
+
+(defvar this_compilation nil "the current compilation")
+
+(warn "should add disc_super to class_discr")
+
+(defun cpusec () (float (/ (get-internal-run-time) internal-time-units-per-second )))
+
+
+;; program sbstract syntax tree 
+(defstruct prog_src)
+
+(defstruct (prog_if (:include prog_src)) 
+  cond_expr then_expr else_expr)
+
+(defstruct (prog_setq (:include prog_src))
+  setq_var setq_expr)
+
+(defstruct (prog_apply (:include prog_src))
+  appl_fun appl_args)
+
+(defstruct (prog_primitive (:include prog_src))
+  prim_oper prim_args)
+
+(defstruct (prog_chunk (:include prog_src)) ;chunks are used in primitive normalization
+  chunk_args chunk_type)
+
+(defstruct (prog_cstring (:include prog_src)) ;A C string constant
+   c_str)
+
+(defstruct (prog_quotesym (:include prog_src)) ;A quoted symbol or keyword
+   qsym)
+
+;;; the normalisation of a primitive requires its expansion as
+;;; primitive calls ans primitive chunks
+
+(defstruct (prog_let (:include prog_src))
+  let_bindings let_body)
+
+(defstruct (prog_send (:include prog_src))
+  send_sel send_recv send_args)		
+
+(defstruct (prog_unsafe_get_field (:include prog_src))
+  uget_field uget_obj)
+
+(defstruct (prog_unsafe_put_fields (:include prog_src))
+  uput_obj uput_keys)
+
+;; make an instance at runtime ; 
+(defstruct (prog_make_instance (:include prog_src))
+  mki_class mki_keys mki_classdef	;the classdef is internal, neede for normal forms
+)	
+
+(defstruct (prog_forever (:include prog_src))
+  forever_bind forever_body)
+
+(defstruct (prog_progn (:include prog_src))
+  progn_body)
+
+(defstruct (prog_exit (:include prog_src))
+  exit_bind exit_body)
+
+;internal representation of closed variable occurrence
+(defstruct (prog_closedvar (:include prog_src))
+  clv_var				;the closed variable
+  clv_fun				;the closing function or lambda
+  clv_bind				;the binding of the closed variable
+)
+			
+; internal representation of closure allocation and fill
+(defstruct (prog_makeclosure (:include prog_src))
+  mkclos_fun				; the normalized function or lambda
+  mkclos_closvars				; the list of closed variables
+)
+
+(defstruct (prog_def (:include prog_src)) 
+  def_name)
+
+(defstruct (prog_predef (:include prog_def))
+  predef_rank)
+
+
+;;prog_defun are for defun and for normalized anonymous lambda
+(defstruct (prog_defun (:include prog_def)) ;defined name
+  fun_lambda				    ;if this defun comes from a lambda otherwise nil
+  fun_formals 				;list of formal arguments
+  fun_body				;sequence of body
+  fun_argbindings			;computed argument bindings
+  fun_closvars				;computed closed variable list
+  fun_constants				;computed list of quoted constants
+)
+
+;; prog_lambda are for source lambda
+(defstruct (prog_lambda  (:include prog_src))
+  lambda_formals			;list of formal arguments
+  lambda_body 				;sequence for body
+  lambda_argbindings 			;computed arguments bindings
+  lambda_closvars			;computed closed variable list
+  lambda_uniq				;unique number
+)
+
+
+
+;; prog_multicall are for multiple-binding of secondary results of calls
+(defstruct (prog_multicall (:include prog_src))
+  multicall_formals			;formal list of result variables
+  multicall_call			;the call or send
+  multicall_body			;body
+)
+
+
+(defstruct (prog_defvar (:include prog_predef)) ;@!not yet implemented
+  var_expr)
+
+(defstruct (prog_defclass  (:include prog_predef)) 
+  class_super class_ownfields class_allfields)
+
+(defstruct (prog_definstance  (:include prog_predef)) 
+  inst_class inst_objnum inst_slots)
+
+(defstruct (prog_defselector  (:include prog_definstance)) 
+)
+
+
+
+(defstruct instance_slot
+  slot_field slot_value)
+
+(defstruct (prog_field (:include prog_def))
+  field_class field_offset)
+
+(defstruct (prog_return (:include prog_src))
+  retexprs)
+
+(defstruct (prog_defprimitive (:include prog_def))
+  primitive_formals primitive_type primitive_expansion)
+
+;; for each variable occurrence, we need to know if the variable is
+;; closed within the current function (or lambda) or bound inside
+
+(defstruct cold_compenv
+  serial		 ;serial number
+  dict 					;dictionnary of bindings (by name)
+  prev 					;link to previous environment
+  for 					;optional function for which this env is made
+)
+
+;; flag to set to revert to default compenv printing
+(defvar cold_compenv_defprint nil)
+
+;; variable counting the number of compenv printing
+(defvar count_compenv_print 0)
+
+;; internal function to compute an hashcode for the dict of an environment
+(defun envdicthash (env)
+  (let ( (h (cold_compenv-serial env)) )
+    (maphash (lambda (k v) 
+	       (setq h (logand #xFFFFFFFF (+ h (* 8 (sxhash k)) (sxhash v)))))
+	     (cold_compenv-dict env))
+    h
+))
+
+
+;; internal hashtable to avoid printing manytimes the same environ
+;; we map an environment to its envdicthash and its printing counter 
+(defvar envprintdict (make-hash-table :size 1000))
+
+;; for less verbose traces & debugs
+(defmethod  print-object ((ob cold_compenv) st)
+  (if cold_compenv_defprint 
+      (call-next-method ob st)
+    (progn
+      (incf  count_compenv_print)
+      (format st "CompEnv/~d<#~d>{~:@_"  (cold_compenv-serial ob) count_compenv_print)
+      (let ( (curenv ob) 
+	     (curdepth 0)
+	     )
+	(loop while curenv do
+	      (finish-output st)
+	      (let* ( (edict (cold_compenv-dict curenv))
+		      (edicthash (envdicthash curenv))
+		      (eprev (cold_compenv-prev curenv))
+		      (efor  (cold_compenv-for curenv)) 
+		      (eserial (cold_compenv-serial curenv))
+		      (epri (gethash curenv envprintdict))
+		      (eprihash (and epri (car epri)))
+		      (epricnt (and epri (cdr epri)))
+		      )
+		(if (and 
+		     (> curdepth 0) 
+		     (eq eprihash edicthash)
+		     (> epricnt (- count_compenv_print 64)))
+		    (format st "!!*seecompenv/~d <<^^h~x#~d>>~:@_" eserial edicthash epricnt)
+		  (let ( (newpri (cons edicthash count_compenv_print)) )
+		    (setf  (gethash curenv envprintdict) newpri)
+		    (format st "!compenv/~d [~d] <H~x>:~:@_"  
+			    eserial (hash-table-count edict) (envdicthash curenv))
+		    ;; display bindings in a sorted order
+		    (let ( (revkeylist nil) )
+		      (maphash (lambda (k v) 
+				 (declare (ignore v))
+				 (push k revkeylist)) edict)
+		      (mapcar 
+		       (lambda (k) (format st " *~a== ~S~:@_" k (gethash k edict)))
+		       (sort revkeylist (lambda (k1 k2) (string< (symbol-name k1) (symbol-name k2))))
+		       )
+		      )
+		    (if efor 
+			(cond ( (prog_defun-p efor)
+				(format st "!compenv/~d - for defun ~S~:@_" eserial (prog_defun-def_name efor)) )
+			      ( (prog_lambda-p efor)
+				(format st "compenv/~d - for lambda #~d~:@_" eserial (prog_lambda-lambda_uniq efor)) )
+			      ( t
+				(format st "compenv/~d - for? ~S~:_" eserial efor) ))
+		      )
+		    ))
+		(if eprev 
+		    (format st "!compenv/~d prev/~d: ~:@_" eserial (cold_compenv-serial eprev)))
+		(setq curenv eprev)
+		(incf curdepth)
+		)
+	      )
+	)
+      (format st "}~:@_")
+      (finish-output st)
+      )))
+  
+;; for less verbose traces & debugs
+(defmethod  print-object ((ob prog_primitive) st)
+  (let ( (poper (prog_primitive-prim_oper ob))
+	 (pargs (prog_primitive-prim_args ob)) )
+    (if (prog_defprimitive-p poper)
+	(format st "#{Primitive/~a ~<~S~>}" (prog_defprimitive-def_name poper) pargs)
+      (call-next-method ob st))))
+
+
+;; for less verbose 
+(defmethod print-object ((ob prog_closedvar) st)
+  (let ( (cvar (prog_closedvar-clv_var ob))
+	 (cfun (prog_closedvar-clv_fun ob))
+	 (cbind (prog_closedvar-clv_bind ob)) )
+  (format st "#{ProgClosedVar/~a" cvar)
+  (if (prog_defun-p cfun) 
+      (format st " cfun/~a" (prog_defun-def_name cfun))
+      (format st " cfun=~S" cfun))
+  (cond 
+   ( (cold_class_binding-p cbind)
+     (format st " cbind<class:~S>" (cold_class_binding-bname cbind)) )
+   ( t
+     (format st " cbind=~S" cbind)))
+  (format st "}")
+))
+;; for less verbose traces
+(defmethod print-object ((ob prog_defclass) st)
+  (let ( (cname (prog_defclass-def_name ob))
+	 (crank (prog_defclass-predef_rank ob))
+	 (csuper (prog_defclass-class_super ob))
+	 (cownf (prog_defclass-class_ownfields ob))
+	 (callf (prog_defclass-class_allfields ob)) )
+  (format st "#{ProgDefClass/~a" cname)
+  (if crank (format st " predefrank/~S" crank))
+  (if (prog_defclass-p csuper) 
+      (format st " super:~a" (prog_defclass-def_name csuper))
+    (format st " super=~S" csuper))
+  (if cownf (format st " ownfl=~S" cownf))
+  (if callf (format st " allfl=~S" callf))
+  (format st "}")
+))
+
+
+(defmethod print-object ((ob prog_field) st)
+  (let ( (fname (prog_field-def_name ob))
+	 (fclass (prog_field-field_class ob))
+	 (foff (prog_field-field_offset ob)) )
+    (format st "#{ProgField/~a#~d" fname foff)
+    (if (prog_defclass-p fclass)
+	(format st " FldClass/~a" (prog_defclass-def_name fclass))
+      (format st " FldClass=~S" fclass))
+    (format st "}")    
+    ))
+
+(defmethod print-object ((ob prog_return) st)
+  (let ( (re (prog_return-retexprs ob)) )
+    (cond ( (and (consp re) (cdr re))
+	    (progn
+	      (format st "#{ProgReturn~d" (length re))
+	      (mapc (lambda (x) (format st " ~S" x)) re)
+	      (format st "}")
+	      ))
+	  ( (null re) (format st "{ProgReturn0}"))
+	  ( t (format st "{Prog_RETURN ~S}" (car re))))
+    ))
+
+
+(defconstant cold_valid_types_list (list ':value ':long ':bool ':tree ':void  ':cstring	;and others
+				    ))
+
+;; test for valid cold type keyword
+(defun cold_valid_type_keyword_p (k) 
+  (member k cold_valid_types_list))
+
+
+(defvar cold_compenv_serial_count 0)
+
+(defconstant cold_first_env 
+  (progn 
+    (incf cold_compenv_serial_count) 
+    (make-cold_compenv :serial cold_compenv_serial_count)))
+
+(defun cold_fresh_env (parenv)
+  (if parenv (or (cold_compenv-p parenv) 
+		 (error "invalid parent env ~a ~%<::cold_fresh_env>" parenv)))
+  (incf cold_compenv_serial_count)
+  (make-cold_compenv :prev parenv 
+		     :dict (make-hash-table :size 11)
+		     :serial cold_compenv_serial_count))
+
+(defstruct cold_any_binding
+  bname)
+
+(defstruct (cold_macro_binding (:include cold_any_binding))
+  expanser)
+
+
+;; for less verbose traces & debugs
+(defmethod  print-object ((ob cold_macro_binding) st)
+  (format st "#<!cold_macro_binding ~A!>" (cold_macro_binding-bname ob))
+)
+
+(defstruct (cold_class_binding (:include cold_any_binding))
+  classdef 				;the prog_defclass
+  classdata				;the obj_datainstance
+)
+
+(defstruct (cold_field_binding (:include cold_any_binding))
+  fieldef				;the prog_field
+  fieldata				;the obj_datainstance
+)
+
+
+
+(defstruct (cold_primitive_binding  (:include cold_any_binding))
+  primitive
+)
+
+;; for less verbose traces & debugs
+(defmethod  print-object ((ob cold_primitive_binding) st)
+  (if (prog_defprimitive-p (cold_primitive_binding-primitive ob))
+      (format st "#<!cold_primitive_binding ~A!>" (cold_primitive_binding-bname ob))
+    (call-next-method ob st)
+))
+
+
+
+
+(defstruct (cold_function_binding  (:include cold_any_binding))
+  function
+  fclodata					;function closure data 
+)
+
+;; for less verbose traces & debugs
+(defmethod  print-object ((ob cold_function_binding) st)
+  (if (prog_defun-p (cold_function_binding-function ob))
+      (format st "#<!cold_function_binding ~A!>" (cold_function_binding-bname ob))
+    (call-next-method ob st)
+))
+
+(defstruct (cold_typed_binding (:include cold_any_binding))
+  type)
+
+(defstruct (cold_instance_binding (:include cold_typed_binding))
+  instancedef instancedata)
+
+(defstruct (cold_selector_binding (:include cold_typed_binding))
+  selectordef selectordata)
+
+(defstruct (cold_let_binding  (:include cold_typed_binding))
+  expr 
+)
+
+(defstruct (cold_value_binding  (:include cold_typed_binding))
+  val 
+  compilrole 				;optional compiler role, eg SELECTOR 
+)
+;;; maybe we need a cold_fieldvalue_binding which is a
+;;; cold_value_binding and also knows about the field at compile time
+;;; and likewise for classes and instances and selectors
+
+(defstruct (cold_code_binding  (:include cold_typed_binding))
+  code 
+)
+
+
+(defstruct (cold_formal_binding (:include cold_typed_binding))
+  rank 
+  )
+
+
+(defstruct (cold_cdata_binding (:include cold_typed_binding))
+  cdata)
+
+(defstruct (cold_forever_binding (:include cold_typed_binding))
+  uniq					;unique gensymed id
+)
+
+(defstruct (cold_obforever_binding (:include cold_forever_binding))
+  lobvar					;forever objvar
+)
+
+
+;; for ease of trace & debugging
+(defmethod print-object ((ob cold_let_binding) st)
+  (let ( (bna (cold_any_binding-bname ob))
+	 (bty (cold_typed_binding-type ob))
+	 (bex (cold_let_binding-expr ob)) )
+  (format st "{LetBi[~a" bna)
+  (if bty (format st " :~s" bty))
+  (format st " := ~S ]}" bex)
+))
+
+
+;; convert a keyword :AA to symbol AA
+(defun keyword2symbol (k) 
+  (if (keywordp k) (intern (symbol-name k)) k))
+
+
+;; function to find a binding
+(defun cold_find_binding (nam env)
+  (and (cold_compenv-p env)
+       (let ((dict (cold_compenv-dict env)))
+	 (or (and 
+	      (hash-table-p dict)
+	      (gethash nam dict))
+	     (cold_find_binding nam (cold_compenv-prev env))
+	 ))
+       ))
+
+;;; function to find a binding and also return the reversed list of enclosing functions
+(defun cold_enclosed_find_binding (nam env)
+  (labels (
+	   (recscan (nam env lifun)
+		    (and (cold_compenv-p env)
+			 (let ( (dict (cold_compenv-dict env))
+				(envprev  (cold_compenv-prev env))
+				(newlifun 
+				 (let ( (forf (cold_compenv-for env)) )
+				   (if forf (cons forf lifun) lifun))) )
+			   (if (hash-table-p dict)
+			       (let ( (bi (gethash nam dict)) )
+				 (if bi (values bi lifun)
+				   (recscan nam envprev newlifun)))
+			     (recscan nam envprev newlifun)
+			     ))))
+	   )
+    (recscan nam env ())))
+		    
+      
+
+
+(defun cold_tested_find_binding (nam env test)
+  (and (cold_compenv-p env)
+       (let ((dict (cold_compenv-dict env)))
+	 (or (and 
+	      (hash-table-p dict)
+	      (gethash nam dict))
+	     (and 
+	      (funcall test env)
+	      (cold_find_binding nam (cold_compenv-prev env))
+	 )))))
+
+	      
+  
+(defun cold_put_binding (cbind env)
+  (assert (cold_compenv-p env))
+  (or (cold_any_binding-p cbind)
+      (error "bad cold binding ~S to put in env ~S~%<::cold_put_binding>" cbind env))
+  (let ( (bnam (cold_any_binding-bname cbind))
+	 (dict (cold_compenv-dict env))) 
+    (or (hash-table-p dict) 
+	(progn 
+	  (setq dict (make-hash-table :size 13))
+	  (setf (cold_compenv-dict env) dict)
+	  ))
+    (setf (gethash bnam dict) cbind)
+    )
+)
+
+(defun cold_define_macro (nam expans env)
+  (let ( (mbind (make-cold_macro_binding 
+		 :bname nam :expanser expans)) )
+    (cold_put_binding mbind env))
+)
+
+
+(defun cold_macroexpand (sexpr env)
+  (flet 
+   ( (makeapply 
+      (f args)
+      (assert (not (keywordp f)) 
+	      (f sexpr) 
+	      "invalid fun f=~S to makeapply in macroexpand sexpr=~S" f sexpr)
+      (make-prog_apply :appl_fun f :appl_args args)) 
+     (makeprim 
+      (p args)
+      (make-prog_primitive :prim_oper p :prim_args args))
+     (expandlist
+      (l)
+      (mapcar (lambda (e) (cold_macroexpand e env)) l)
+      )
+     )
+   (if (consp sexpr)
+       (let ( (oper (first sexpr))
+	      (args (rest sexpr)) )
+	 (if (listp oper)
+	     (makeapply 
+	      ;; maybe this is too simple, what if the macroexapsnion
+	      ;; yields a slector...
+	      (cold_macroexpand oper env) (expandlist args))
+	   (let ( (obind (cold_find_binding oper env)) )
+	     (cond ((cold_macro_binding-p obind)
+		    (let ( (mexp (cold_macro_binding-expanser obind)) )
+		      (apply mexp (list oper args env))
+		      ))
+		   ((cold_primitive_binding-p obind)
+		    (makeprim (cold_primitive_binding-primitive obind)
+			      (expandlist args))
+		    )
+		   ((cold_field_binding-p obind)
+		    (error "field application not yet implemented ~S~%<::cold_macroexpand>" oper))
+		   ( (or (cold_selector_binding-p obind)
+			 (and (cold_value_binding-p obind)
+			      (eq (cold_value_binding-compilrole obind) 
+				  'SELECTOR)))
+		     (let ( (expargs (expandlist args)) )
+		       (if (null expargs) 
+			   (error "send requires a reciever argument but got none ~S~%<::cold_macroexpand>" oper))
+		     (make-prog_send
+		      :send_sel oper
+		      :send_recv (first expargs)
+		      :send_args (rest expargs)
+		      ))
+		    )
+		   (t (makeapply oper (expandlist args)))
+		   ))))
+     sexpr
+     )))
+
+(defun cold_list_macroexpand (l env)
+  (mapcar (lambda (e) (cold_macroexpand e env)) l))
+
+
+(defmacro defcoldmacro (nam formals &rest body) 
+  `(cold_define_macro ',nam (lambda ,formals ,@body)  cold_first_env)
+)
+
+(defun write_c_comment (outs coms)
+  (write-string "/**!" outs)
+  (let ((lencom (length coms)))
+    (loop 
+     for rk from 0 to (- lencom 2) do
+     (let ( (c (char coms rk)) 
+	    (nc (char coms (+ rk 1)))
+	    )
+       (case c 
+	     (#\/ (if (eq nc #\*) (write-string "/+" outs) (write-char #\/ outs)))
+	     (#\* (if (eq nc #\/) (write-string "*+" outs) (write-char #\* outs)))
+	     (otherwise (write-char c outs))
+	     ))
+     )
+    )
+  (write-string "!**/" outs)
+  (if (find #\Newline coms) (write-char #\Newline outs))
+)
+
+(defmacro format_c_comment (str fmtstr &rest args)
+  (let ((sy (gentemp "FORMATCCOMM_")))
+    `(let ( (,sy (format nil ,fmtstr ,@args)) )
+       (write_c_comment ,str ,sy)
+       )
+    )
+)
+
+(defun str2cstr (istr)
+  (assert (stringp istr))
+  (with-output-to-string
+    (s)
+    (write-char #\" s)
+    (map nil
+	 (lambda (c)
+	   (case c
+		  (#\\ (write-string "\\\\" s))
+		  (#\" (write-string "\\\"" s))
+		  (#\' (write-string "\\\'" s))
+		  (#\Newline (write-string "\\\n" s))
+		  (#\Tab (write-string "\\\t" s))
+		  (otherwise (if (standard-char-p c) 
+				 (write-char c s)
+			       (format s "\\x~2,'0x" (char-code c))))
+		 )
+	   )
+	 istr
+	 )		
+    (write-char #\" s)      
+    )
+  )
+
+(defun lambda_args_bindings (formals)
+  (let ( (argrk 0)
+	 (argtype :value) 
+	 (arglist formals)
+	 (revargbind nil)
+	 )
+    (loop
+     (if (null arglist) 
+	 (return (reverse revargbind)))
+     (let ( (curarg (car arglist))
+	    (restarglist (cdr arglist)) )
+       (setq arglist restarglist)
+       (cond 
+	( (keywordp curarg)
+	  (or (cold_valid_type_keyword_p curarg) 
+	      (error "invalid formal keyword ~a in formals list ~s ~% <::lambda_args_binding>"
+		     curarg formals))
+	  (setq argtype curarg)
+	  )
+	( (symbolp curarg)
+	  (let ( (abind (make-cold_formal_binding :bname curarg
+						  :rank argrk 
+						  :type argtype)) )
+	    (push abind revargbind)
+	    (setq argrk (1+ argrk))
+	    )
+	  )
+	( t (error "invalid formal (not a symbol or keyword) ~a in formals list ~s ~% <::lambda_args_binding>" curarg formals) )
+	)
+       ))))
+
+
+(defvar cold_delayed_task_revlist nil)
+
+(defun cold_delayed_do (msg taskfun)
+  (assert (stringp msg))
+  (or (functionp taskfun) 
+      (error "cold_delayed_do bad taskfun ~s of type ~s ~% <::cold_delayed_do>"
+	     taskfun (type-of taskfun)))
+  (push (cons msg taskfun) cold_delayed_task_revlist)
+)
+
+(defmacro cold_delay (msg &rest body)
+  `(cold_delayed_do ,msg (function (lambda () ,@body))))
+
+(defun cold_run_delayed_tasks (&optional msg)
+  (and msg (or (stringp msg) (error "bad msg in cold_run_delayed_tasks ~S" msg)))
+  (loop 
+    (if (null cold_delayed_task_revlist) (return))
+    (let ( (taskslist (reverse cold_delayed_task_revlist)) )
+      (setq cold_delayed_task_revlist nil)
+      (map nil (lambda (taskcons) 
+		 ; (warn "delay running task ~S~%" (car taskcons))
+		 (apply (cdr taskcons) ())) taskslist)
+      ))
+  )
+
+
+(defcoldmacro defprimitive (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind 
+   (primnam formals type &rest body) args
+   (or (cold_valid_type_keyword_p type) 
+       (error "bad type ~S in defprimitive ~S" type args))
+   (assert (every (lambda (x) (or (symbolp x) (numberp x) (stringp x) (not (prog_src-p x)))) body))
+   (let ( (prim
+	   (make-prog_defprimitive 
+	    :def_name primnam
+	    :primitive_formals (lambda_args_bindings formals)
+	    :primitive_type type 
+	    :primitive_expansion body)) )
+     (let ( (pbind (make-cold_primitive_binding
+		    :bname primnam :primitive prim)) )
+       (cold_put_binding pbind env))
+     prim
+     )
+   )
+  )
+
+;; a defun function should be expanded in an environment where the
+;; defined function is bound, hence we use cold_delay, and the body
+;; should be expaned with the formals bound
+(defcoldmacro defun (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind 
+   (funam formals &rest body) args
+   (let* ( 
+	  (argbindseq (lambda_args_bindings formals))
+	  (newenv 
+	   (let ( (nenv (cold_fresh_env env)) )
+	     (map nil 
+		  (lambda (abind)  (cold_put_binding abind nenv)) 
+		  argbindseq)
+	     nenv
+	     ))
+	  (fun
+	   (make-prog_defun 
+	    :def_name funam
+	    :fun_formals formals
+	    :fun_argbindings argbindseq
+	    )) 
+	  (fbind (make-cold_function_binding :bname funam :function fun
+					     :fclodata (make-obj_dataclosure
+							:comname funam)
+					     )) 
+	  )
+     (cold_put_binding fbind env)
+     (cold_delay
+      (format nil "expand defun ~S" funam)
+      (setf (prog_defun-fun_body fun)  
+	    (mapcar 
+	     (lambda (e) (cold_macroexpand e newenv))
+	     body)
+	    )
+      )
+     fun
+     )))
+
+
+
+;;; a class binding
+(defcoldmacro defclass (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind
+   (cname &key predef super fields) args
+   (assert (symbolp cname) (cname) "invalid class name ~S" cname)
+   (let* 
+       ( (pdefclass (make-prog_defclass :def_name cname :predef_rank predef)) 
+	 (clabind (make-cold_class_binding :bname cname :classdef pdefclass))
+	 (superclass 
+	  (and super
+	       ;;;; we really should consider macro expansion on super
+	       (or (symbolp super) (error "bas super ~S in defclass ~S" super args))
+	       (let ( (superbind (cold_find_binding super env)) )
+		 (or (cold_class_binding-p superbind) 
+		     (error "bad superbinding ~S in defclass ~S" superbind args))
+		 (cold_class_binding-classdef superbind))))
+	 (superallfields
+	  (and super
+	       (prog_defclass-class_allfields superclass)))
+	 (off (if super (length superallfields) 0))
+	 )
+     (cold_put_binding clabind env)
+     (setf (prog_defclass-class_super pdefclass) superclass)
+     (let ( (fieldseq 
+	     (mapcar 
+	      (lambda (f) 
+		(or (symbolp f) (error "bad field ~S in defclass ~S" f args))
+		(if (cold_find_binding f env) 
+		    (error "field ~S already bound in defclass ~S" f args))
+		(let* 
+		    ( (field (make-prog_field :def_name f :field_class pdefclass :field_offset off)) 
+		      (fieldbind (make-cold_field_binding :bname f :fieldef field)) )
+		  (incf off)
+		  (cold_put_binding fieldbind env)
+		  field))
+	      fields)) )
+       ;; copy-list just to avoid lots of circular ref in debug
+       (setf (prog_defclass-class_ownfields pdefclass) 
+	     (copy-list fieldseq))
+       (setf (prog_defclass-class_allfields pdefclass) 
+	     (copy-list (append superallfields fieldseq)))
+       pdefclass			;expansion result for defclass
+       )
+     )))
+       
+
+
+;;; common code to definstance and defselector
+(defun instancemakerfun (iname iclassname idata env msg makfun bindfun)
+  (let ( (revslots ())
+	 (iobjnum ())
+	 (ipredef ())
+	 (curdata idata) 
+	 (bindclass (cold_find_binding iclassname env))
+	 )
+    (or (symbolp iname) 
+	(error "~A: expecting name but got ~S" msg iname))
+    (or (cold_class_binding-p bindclass)
+	(error "~A: ~A bad classname ~A" msg iname iclassname))
+    (let ((iclass (cold_class_binding-classdef bindclass)))
+      (assert (prog_defclass-p iclass))
+      (loop while (consp curdata) do
+	    (or (rest curdata)
+		(error "~A: odd arg  ~A  ~S" msg iname idata))
+	    (let ((curk (first curdata))
+		  (cura (second curdata)) )
+	      (setq curdata (cddr curdata))
+	      (or (keywordp curk) 
+		  (error "~A: expecting slot keyword but got ~S  ~A ~S" msg curk iname idata))
+	      (cond ( (eq curk ':obj_num)
+		      (setq iobjnum (cold_macroexpand cura env)) )
+		    ( (eq curk ':predef)
+		      (setq ipredef (cold_macroexpand cura env)) )
+		    ( t
+		      (let ((fld (find-if 
+				  (lambda (f) (equal (string (prog_field-def_name f)) (string curk))) 
+				  (prog_defclass-class_allfields iclass)
+				  )))
+			(or fld (error "~A: unexpected field ~S in ~A ~S" msg curk iname idata))
+			(let ((slodef (make-instance_slot 
+				       :slot_field fld
+				       :slot_value 
+				       (cold_macroexpand cura env))))
+			  (push slodef revslots))
+			)))))
+      (let* ( 
+	     (nval
+	      (funcall makfun
+		       iname
+		       ipredef
+		       iclass
+		       iobjnum
+		       (reverse revslots)))
+	     (nbind (funcall bindfun iname nval))
+	     )
+	(cold_put_binding nbind env)
+	nval
+	))))
+
+;;; a class binding
+(defcoldmacro definstance (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind
+   (iname iclassname &rest idata) args
+   (instancemakerfun iname iclassname idata env "definstance coldmacro" 
+		     ;; make value function
+		     (lambda (iname ipredef iclass iobjnum islots)
+		       (make-prog_definstance :def_name iname
+					      :predef_rank ipredef
+					      :inst_class iclass
+					      :inst_objnum iobjnum
+					      :inst_slots islots))
+		     ;; make binding function
+		     (lambda (iname nval)
+		       (make-cold_instance_binding
+			:bname iname
+			:type ':value
+			:instancedef nval
+		       ))
+		     )))
+
+
+
+(defcoldmacro defselector (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind
+   (iname iclassname &rest idata) args
+   (instancemakerfun iname iclassname idata env "defselector coldmacro" 
+		     ;; make value function
+		     (lambda (iname ipredef iclass iobjnum islots)
+		       (make-prog_defselector :def_name iname
+					      :predef_rank ipredef
+					      :inst_class iclass
+					      :inst_objnum iobjnum
+					      :inst_slots islots))
+		     ;; make binding function
+		     (lambda (iname nval)
+		       (make-cold_selector_binding
+			:bname iname
+			:type ':value
+			:selectordef nval
+			))
+		     )))
+
+
+;; the body of a lambda should be macroexpanded with the formals bound
+(defvar lambda_counter 0)
+(defcoldmacro lambda (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind 
+   (formals &rest body) args
+   (let* ( 
+	  (argbindseq (lambda_args_bindings formals))
+	  (newenv 
+	   (let ( (nenv (cold_fresh_env env)) )
+	     (map nil 
+		  (lambda (abind)  (cold_put_binding abind nenv)) 
+		  argbindseq)
+	     nenv
+	     ))
+	  (newlamb
+	   (make-prog_lambda :lambda_formals formals
+			     :lambda_body 
+			     (mapcar 
+			      (lambda (e) (cold_macroexpand e newenv))
+			      body)
+			     :lambda_argbindings argbindseq
+			     :lambda_uniq (incf lambda_counter)
+			     :lambda_closvars nil))
+	  )
+     newlamb
+)))
+
+
+;; the forever syntax (FOREVER <label> [<type>] <body...>)
+(defcoldmacro forever (nam args env)
+  (declare (ignore nam))
+  (let ( (foreverlab (pop args))
+	 (forevertype :value)
+	 (foreverbody nil) 
+	 (newenv (cold_fresh_env env))
+	 ) 
+    (or (symbolp foreverlab) (error "bad forever label in forever ~S" args))
+    (if (cold_valid_type_keyword_p (first args))
+	(setq forevertype (pop args)))
+    (if (eq forevertype ':void) (error "forever type cannot be void in forever ~S" args))
+    (setq foreverbody args)
+    (let ( (foreverbind (make-cold_forever_binding 
+		      :bname foreverlab
+		      :type forevertype
+		      :uniq (gentemp "_FOREVER_"))) )
+      (cold_put_binding foreverbind newenv)
+      (make-prog_forever :forever_bind foreverbind 
+		      :forever_body (mapcar (lambda (c) (cold_macroexpand c newenv)) foreverbody))
+    )))
+
+;; the progn syntax (PROGN <body....>)
+(defcoldmacro progn (nam args env)
+  (declare (ignore nam))
+  (make-prog_progn 
+   :progn_body (mapcar  (lambda (c) (cold_macroexpand c env)) args))
+)
+
+;; the UNSAFE_GET_FIELD syntax (UNSAFE_GET_FIELD field objexpr)
+(defcoldmacro unsafe_get_field (nam args env)
+  (declare (ignore nam))
+  (let (
+	(iargs args)
+	(ifldnam (pop args))
+	(iobjexpr (pop args)) )
+    (if args (error "too many arguments to unsafe_get_field ~S" iargs))
+    (or (keywordp ifldnam) 
+	(error "first arg should be a keyword fieldname: unsafe_get_field ~S" iargs))
+    (make-prog_unsafe_get_field
+     :uget_field ifldnam
+     :uget_obj  (cold_macroexpand iobjexpr env)
+     )
+))
+
+;; the UNSAFE_PUT_FIELDS syntax (UNSAFE_PUT_FIELDS objexpr fld1name fld1expr ...)
+(defcoldmacro unsafe_put_fields (nam args env)
+  (declare (ignore nam))
+  (let (
+	(iargs args)
+	(iobjexpr (pop args)) 
+	(irevkeys nil)
+	)
+    (loop while (and (consp args) (second args)) do
+	  (let ( 
+		(curfldnam (pop args))
+		(curvalexpr (pop args))
+		)
+	    (or (keywordp curfldnam) 
+		(error "expecting keyword fieldname but got ~S in unsafe_put_fields ~S"
+		       curfldnam iargs))
+	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
+	  ))
+    (make-prog_unsafe_put_fields
+     :uput_obj iobjexpr
+     :uput_keys (reverse irevkeys)
+     )
+))
+
+
+;; the MAKE_INSTANCE syntax (MAKE_INSTANCE objexpr fld1name fld1expr ...)
+(defcoldmacro make_instance (nam args env)
+  (declare (ignore nam))
+  (let (
+	(iargs args)
+	(iclass (pop args)) 
+	(irevkeys nil)
+	)
+    (or (symbolp iclass) (error "make_instance need a class symbol ~S" iargs))
+    (loop while (and (consp args) (second args)) do
+	  (let ( 
+		(curfldnam (pop args))
+		(curvalexpr (pop args))
+		)
+	    (or (keywordp curfldnam) 
+		(error "expecting keyword fieldname but got ~S in make_instance ~S"
+		       curfldnam iargs))
+	    (push (cons curfldnam  (cold_macroexpand curvalexpr env)) irevkeys)
+	  ))
+    (make-prog_make_instance
+     :mki_class (normalize_symbol iclass env)
+     :mki_classdef iclass
+     :mki_keys (reverse irevkeys)
+     )
+))
+
+;; the EXIT syntax (EXIT <label> [<expr>])
+(defcoldmacro exit (nam args env)
+  (declare (ignore nam))
+  (let ( (exitlab (pop args)) 
+	 (exitexprs args)
+	 )
+    (or (symbolp exitlab) 
+	(error "EXIT need a symbol label: ~S" args))
+    (flet ((testnoforenv (env) (null (cold_compenv-for env))))
+	  (let ( (exitbind (cold_tested_find_binding exitlab env (function testnoforenv))) )
+	    (if (null exitbind) 
+		(error "EXIT label ~S is not bound" exitlab))
+	    (or (cold_forever_binding-p exitbind)
+		(error "label EXIT label ~S not bound to forever ~S" exitlab exitbind))
+	    (make-prog_exit 
+	     :exit_bind exitbind
+	     :exit_body (mapcar (lambda (c) (cold_macroexpand c env)) exitexprs)
+	    )))))
+
+
+;; SETQ syntax
+(defcoldmacro setq (nam args env)
+  (declare (ignore nam))
+  (if (rest (rest args)) (error "SETQ with more than two args ~S" args))
+  (destructuring-bind 
+   (var expr) args
+   (or (symbolp var) (error "bad setq macro args ~S" args))
+   (make-prog_setq :setq_var var
+		   :setq_expr (cold_macroexpand expr env)
+   )))
+
+
+;;; QUOTE syntax (only for symbols or keywords)
+(defcoldmacro quote (nam args env)
+  (declare (ignore nam))
+  (if (rest args) (error "quote with more than one arg ~S" args))
+  (let ((qarg (first args)))
+    (or (symbolp qarg) (keywords qarg)
+	(error "quote a non-symbol ~S" qarg))
+    (make-prog_quotesym :qsym qarg)
+))
+
+;; IF syntax
+(defcoldmacro if (nam args env)
+  (declare (ignore nam))
+  (destructuring-bind 
+   (scond sthen &optional selse) args
+   (make-prog_if 
+    :cond_expr (cold_macroexpand scond env)
+    :then_expr (cold_macroexpand sthen env)
+    :else_expr (if selse (cold_macroexpand selse env)))))
+
+;;; COND pseudo syntax
+;;; (COND ( t1 a1_1 a1_2 ) ( t2 a2_1 )) is expansed into 
+;;;; (IF t1 (PROGN a1_1 a1_2) (IF t2 a2_1))
+(defcoldmacro cond (nam args env)
+  (declare (ignore nam))
+  (let ( (rescond nil) )
+    (loop 
+     for clause in (reverse args)
+     for rk from 1
+     do
+     ; (warn "COND clause ~#d == ~S~%" rk clause)
+     ;; special case for last (t ...) or (:else ...) clause
+     (if (and (<= rk 1) (member (first clause) '(t :else else)))
+	 (if (rest (rest clause))
+	     (setq rescond (make-prog_progn 
+			    :progn_body (mapcar  
+					 (lambda (i) (cold_macroexpand i env))
+					 (rest clause))))
+	   (setq rescond (cold_macroexpand (second clause) env)))
+       (let ( (lenclause (length clause)) )
+	 (case lenclause 
+	       ( 1 (let ( (cndexp (cold_macroexpand (first clause) env)) )
+		     (setq rescond (make-prog_if 
+				    :cond_expr cndexp 
+				    :then_expr cndexp 
+				    :else_expr rescond))))
+	       ( 0 )
+	       ( 2 (let ( (cndexp (cold_macroexpand (first clause) env))
+			  (thnexp (cold_macroexpand (second clause) env)) )
+		     (setq rescond (make-prog_if 
+				    :cond_expr cndexp 
+				    :then_expr thnexp 
+				    :else_expr rescond))))
+	       (otherwise 
+		(let ( (cndexp  (cold_macroexpand (first clause) env))
+		       (progexprs (mapcar (lambda (i) (cold_macroexpand i env)) (rest clause))) )
+		  (setq rescond (make-prog_if
+				 :cond_expr cndexp
+				 :then_expr (make-prog_progn :progn_body progexprs)
+				 :else_expr rescond))))
+	       )))
+    ; (warn "COND partial rescond #~d == ~S~%" rk rescond)
+     )
+   ; (warn "COND ~s expands to ~S ;;COND expansion~%" args rescond)
+    rescond
+    ))
+
+;;; AND pseudo syntax
+;;; (AND a1 a2) is expansed into (IF a1 a2)
+;;; (AND a1 a2 a3) is expansed into (IF a1 (IF a2 a3))
+(defcoldmacro and (nam args env)
+  (declare (ignore nam))
+  ;; reject (and) without arguments
+  (if (null args) (error "(and) without any arguments"))
+  (labels ( (expand (a)
+		    (if (null (rest a)) 
+			(first a)
+		      (let ( (a1 (first a)) )
+			    (make-prog_if
+			     :cond_expr a1
+			     :then_expr (expand (rest a))))))
+	    ) 
+	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) 
+  ))
+
+;;; OR pseudo syntax
+;;; (OR a1) is expanded as a1
+;;; (OR a1 a2) is expanded as (IF a1 a1 a2)
+;;; (OR a1 a2 a3) is expanded as (IF a1 a1 (IF a2 a2 a3))
+(defcoldmacro or (nam args env)
+  (declare (ignore nam))
+  ;; reject (or) without arguments
+  (if (null args) (error "(or) without any arguments"))
+  (labels ( (expand (a)
+		    (if (null (rest a)) (first a)
+		      (let ( (a1 (first a)) )
+			    (make-prog_if
+			     :cond_expr a1
+			     :then_expr a1
+			     :else_expr (expand (rest a)))))) )
+	  (expand (mapcar (lambda (c) (cold_macroexpand c env)) args)) )
+  )
+
+;; LET syntax
+(defcoldmacro let (nam args env)
+  (declare (ignore nam))
+  (let ( (srcbinds (first args))
+	 (srcbody (rest args)) )
+    (let ( (revbindseq nil) 
+	   (newenv (cold_fresh_env env))
+	   )
+      (flet ( (bindhandle
+	       (sbind)
+	       (or (consp sbind) (error "bad src binding ~S in let ~S" sbind args))
+	       (let ( (f (first sbind)) 
+		      (lensbind (length sbind))
+		      )
+		 (let ( (newbind		       
+			 (cond
+			  ( (and (eq lensbind 3) (keywordp f))
+			    (let ( (sy (second sbind))
+				   (ex (third sbind)) )
+			      (or (cold_valid_type_keyword_p f)
+				  (error "bad type keyword ~S in let ~S" f args))
+			      (or (symbolp sy)
+				  (error "non symbol ~S to bind  in let ~S" sy args))
+			      (let ( (expa (cold_macroexpand ex newenv)) )
+				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
+				(make-cold_let_binding :bname sy 
+						       :expr expa
+						       :type f)
+				)))
+			  ( (eq lensbind 2) 
+			    (let ( (sy (first sbind))
+				   (ex (second sbind)) )
+			      (or (symbolp sy)
+				  (error "non symbol ~S to bind  in let ~S" sy args))
+			      (let ( (expa (cold_macroexpand ex newenv)) )
+				(if (consp expa) (error "bad expa ~S in let ~S" expa args))
+				(make-cold_let_binding :bname sy 
+						       :expr expa))))
+			  ( t (error "bad binding ~S in let ~S" sbind args) )
+			  )))
+		   (push newbind revbindseq)
+		   (cold_put_binding newbind newenv)
+		   ))))
+	    (mapc (function bindhandle) srcbinds)
+	    (let ( (res
+		    (make-prog_let
+		     :let_bindings (reverse revbindseq)
+		     :let_body (cold_list_macroexpand srcbody newenv)
+		     )) )
+	      res
+	      )))))
+
+
+;;; MULTICALL syntax
+(defcoldmacro multicall (nam args env)
+  (declare (ignore nam))
+  (if (< (length args) 3) (error "too few arguments to multicall ~S" args))
+  (let* (
+	 (arglist args)
+	 (muformalseq (pop args))
+	 (mucall (pop args))
+	 (mubody args) 
+	 (muformalist (lambda_args_bindings muformalseq))
+	 (mufirst (first muformalist))
+	 (xcall (cold_macroexpand mucall env))
+	 (newenv (cold_fresh_env env))
+	 )
+    (or (prog_apply-p xcall) (prog_send-p xcall)
+	(error "multicall not of ~S application or send ~S" xcall arglist))
+    (assert (cold_formal_binding-p mufirst))
+    (mapc (lambda (b) (cold_put_binding b newenv)) muformalist)
+    (or (eq (cold_typed_binding-type mufirst) ':value)
+	(error "first formal of multicall should be a :value in multicall ~S" 
+	       arglist))
+    (let ( (mc
+	    (make-prog_multicall
+	     :multicall_formals muformalist
+	     :multicall_call xcall
+	     :multicall_body  (mapcar (lambda (b) (cold_macroexpand b newenv)) mubody)) 
+	    ) )
+      mc
+      )))
+
+
+(defcoldmacro return (nam args env)
+  (declare (ignore nam))
+  (let ( (retpr
+	  (make-prog_return :retexprs (mapcar (lambda (b) (cold_macroexpand b env)) args))) )
+    ;(break "return macro retptr ~S~%" retpr)
+   retpr))
+
+
+(defgeneric bind_normal_code (cod env)
+  (:documentation "normalization of (any) Basilys code, gives binding+normal code")
+)
+
+
+(defgeneric normalize_toplev (def env)
+  (:documentation "normalize a toplev definition or code"))
+
+(defmethod bind_normal_code ((cod prog_src) env)
+  (declare (ignore env))
+  ;; some stuff are already normal, eg defprimitive or quotsym
+  (values nil cod)
+)
+
+
+; we frequently may need to make an optional let around something
+(defun cold_wrap_let (revbindings cod)
+  (assert (listp revbindings))
+  (if revbindings
+      (progn 
+	(assert (cold_let_binding-p (first revbindings)))
+	(make-prog_let 
+	 :let_bindings (reverse revbindings)
+	 :let_body cod))
+    cod
+    )
+  )
+
+; likewise, but needing a sequence
+(defun cold_wrap_letseq (revbindings cod)
+  (assert (listp revbindings))
+  (if revbindings
+      (progn 
+	(assert (cold_let_binding-p (first revbindings)))
+	(make-prog_let 
+	       :let_bindings (reverse revbindings)
+	       :let_body cod))
+    cod)
+  )
+
+;; likewise, producing a list
+(defun cold_wrap_letlist (revbindings cod)
+  (assert (listp revbindings))
+  (if revbindings
+      (progn 
+	(assert (cold_let_binding-p (first revbindings)))
+	(list (make-prog_let 
+	       :let_bindings (reverse revbindings)
+	       :let_body cod)))
+    (if (listp cod) cod (list cod))
+    ))
+  
+
+;;; executable toplev normalisation
+(defmethod normalize_toplev ((cod prog_src) env)
+  (multiple-value-bind
+      (rbind ncod)
+      (bind_normal_code cod env)
+      (assert (listp rbind))
+    (cold_wrap_let rbind ncod)
+))
+
+
+
+;;- ;; normalization of a symbol occurrence means seeking if the symbol is
+;;- ;; closed or not and returning a prog_closedvar when appropriate
+;;- (defun normalize_symbol (symb env)
+;;-   (or (symbolp symb)
+;;-       (error "normalize_symbol bad symb ~s ~%... in env ~s~%" symb env))
+;;-   (let ( (resnorm nil) 
+;;- 	 (sbind (cold_find_binding symb env))
+;;- 	 )
+;;-     (labels 
+;;-      (
+;;-       ( knownsymb
+;;- 	(sym closvars)
+;;- 	(or (symbolp sym) (error "bad symbol ~S in knownsymb" sym))
+;;- 	(some (lambda (cv) (eq (prog_closedvar-clv_var cv) sym)) closvars)
+;;- 	)
+;;-       ( envtest 
+;;- 	(env) 
+;;- 	(or (symbolp symb) (error "bad symbol ~S in envtest" symb))
+;;- 	(let ( (forf (cold_compenv-for env)) ) 
+;;- 	  (cond 
+;;- 	   ( (null forf) 
+;;- 	     (warn "normalize_symbol symb ~S null forf ~%" symb)
+;;- 	     )
+;;- 	   ( (prog_defun-p forf) 
+;;- 	     (or (symbolp symb) (error "bad symbol ~S inside envtest defun forf ~S" symb forf))
+;;- 	     (or resnorm 
+;;- 		 (setq resnorm (make-prog_closedvar :clv_var symb 
+;;- 						    :clv_fun forf 
+;;- 						    :clv_bind sbind)))
+;;- 	     (let ( (oldclosvars (prog_defun-fun_closvars forf)) )
+;;- 	       (or (knownsymb symb oldclosvars)
+;;- 		   (setf (prog_defun-fun_closvars forf) (cons resnorm oldclosvars)))
+;;- 	       )
+;;- 	     )
+;;- 	   ( (prog_lambda-p forf)
+;;- 	     (or (symbolp symb) (error "bad symbol ~S inside envtest lambda forf ~S" symb forf))
+;;- 	     (let ( (oldclosvars (prog_lambda-lambda_closvars forf)) )
+;;- 	       (or resnorm 
+;;- 		   (setq resnorm (make-prog_closedvar :clv_var symb 
+;;- 						      :clv_fun forf
+;;- 						      :clv_bind sbind)))
+;;- 	       (or (knownsymb symb oldclosvars)
+;;- 		   (setf (prog_lambda-lambda_closvars forf) (cons resnorm oldclosvars)))
+;;- 	       )
+;;- 	     )
+;;- 	   ( t
+;;- 	      (error "normalize_symbol ~S strange forf ~S ~%" symb forf)
+;;- 	   )))
+;;- 	t				;as a test, envtest return
+;;- 					;true to continue scan of
+;;- 					;environment lists
+;;- 	)
+;;-       )
+;;-      (or (symbolp symb)
+;;- 	 (error "normalize_symbol bad symb before tested ~s ~%... in env ~s~%" symb env))
+;;-      (if (or (cold_class_binding-p sbind)
+;;- 	     (cold_instance_binding-p sbind))
+;;- 	 symb
+;;-        (progn
+;;- 	 (cold_tested_find_binding symb env (function envtest))
+;;- 	 (or resnorm symb)	    ;return value for normalize_symbol
+;;- 	 )))))
+
+(defun normalize_symbol (symb env)
+  (or (symbolp symb)
+      (error "normalize_symbol bad symb ~s ~%... in env ~s~%" symb env))
+  (multiple-value-bind 
+      (bnd revlis)
+      (cold_enclosed_find_binding symb env)
+    (cond ( (null symb)
+	    symb			;nil is always nil
+	    )
+	  ( (cold_class_binding-p bnd)
+	    symb			;should make some progconst
+	    )
+	  ( (cold_instance_binding-p bnd)
+	    symb			;should make some progconst of it
+	    )
+	  ( (cold_selector_binding-p bnd)
+	    symb			;should make some progconst of it
+	    )
+	  ( (cold_function_binding-p bnd)
+	    symb			;should make some progconst of it
+	    )
+	  ( (cold_value_binding-p bnd)
+	    symb			;should make some progconst of it
+	    )
+	  ( (cold_field_binding-p bnd)
+	    symb			;should make some progconst of it
+	    )
+	  ( (null bnd)
+	    (error "normalize_symbol ~S unbound in env ~S <:::normalize_symbol unbound ~S in ~S~%"
+		   symb env symb (and (prog_defun-p normalized_defun) (prog_defun-def_name normalized_defun))))
+	  ( (null revlis) 
+	    symb)
+	  (t (progn
+	       ;; check that a closed symbol is indeed a value
+	       (and (cold_typed_binding-p bnd)
+		    (not (null (cold_typed_binding-type bnd)))
+		    (not (eq (cold_typed_binding-type bnd) ':value))
+		    (error "normalize_symbol ~S closed not value ~S" symb bnd))
+	;       (break "normalize_symbol symb ~S bnd ~S revlis ~S~%" symb bnd revlis)
+	       (let ( (clovs
+		       (mapcar 
+			(lambda (lr)
+			  (assert (prog_lambda-p lr))
+			  (or 
+			   (find-if
+			    (lambda (cv)
+			      (assert (prog_closedvar-p cv))
+			      (eq (prog_closedvar-clv_var cv) symb))
+			    (prog_lambda-lambda_closvars lr))
+			   (let ( (ncv (make-prog_closedvar 
+					:clv_var symb 
+					:clv_fun lr
+					:clv_bind bnd)) )
+			     (push ncv (prog_lambda-lambda_closvars lr))
+			     ncv)))
+			revlis)) )
+		 (first clovs)
+		 ))))))
+
+
+
+;; we need to normalize a sequence, possibly adding new let_bindings
+;; to complex arguments this function returns two results: the
+;; normalized sequence and the reversed list of bindings the prefix is
+;; for gentemp-ing the variables; the revbindseq argument is the
+;; initial value of reversed list of bindings (usually nil)
+(defun normalize_code_sequence (seq env prefix  revbindseq)
+  (or (listp seq) 
+      (error "normalize_code_sequence bad seq ~s" seq))
+  (or (cold_compenv-p env) 
+      (error "normalize_code_sequence bad env ~s" env))
+  (or (stringp prefix)
+      (error "normalize_code_sequence bad prefix ~s" prefix))
+  (or (listp revbindseq) 
+      (error "normalize_code_sequence bad revbindseq ~s" revbindseq))
+  (flet (  (handlexpr 
+	    (exp) 
+	    (cond 
+	     ( (prog_src-p exp)
+	       (let ( (nsym (gentemp prefix)) )
+		 (multiple-value-bind
+		  (normrevbind normexp)
+		  (bind_normal_code exp env)
+		  (assert (listp normrevbind))
+		  (if (consp normexp) 
+		      (error "bad normexp ~S in normalize_code_sequence seq ~S exp ~S" normexp seq exp))
+		  (setq revbindseq (append normrevbind revbindseq))
+		  (let ( (newbind  
+			  (make-cold_let_binding :bname nsym :expr normexp)) )
+		    (if (prog_chunk-p normexp)
+			(setf (cold_typed_binding-type newbind)
+			      (prog_chunk-chunk_type normexp)))
+		    (push newbind
+			  revbindseq))
+		  nsym
+		  ) ))
+	     ( (symbolp exp)
+	       (normalize_symbol exp env) )
+	     ( t exp ))) 
+	   )
+	(values (mapcar (function handlexpr) seq) revbindseq)))
+
+
+(defmethod bind_normal_code ((cod null) env)
+  (declare (ignore env))
+  (values nil nil)
+)
+
+(defmethod bind_normal_code ((cod t) env)
+  (declare (ignore env))
+;  (warn "bind_normal_code t ~S env ~S" cod env)
+  (values nil cod)
+)
+
+(defmethod bind_normal_code ((cod symbol) env)
+  (values nil (normalize_symbol cod env)))
+
+
+(defmethod bind_normal_code ((cod prog_setq) env)
+  (let ( (va (prog_setq-setq_var cod))
+	 (ex (prog_setq-setq_expr cod)) )
+    (or (symbolp va) (error "prog_setq bad variable ~S~%"))
+    (let ((nva (normalize_symbol va env)))
+      (multiple-value-bind 
+       (nexs pbindseqrev)
+       (normalize_code_sequence (list ex) env "_SETQ_" nil)
+       (assert (null (rest nexs)))
+       (values nil
+	       (cold_wrap_let pbindseqrev
+			      (make-prog_setq 
+			       :setq_var nva
+			       :setq_expr (first nexs)
+			       )))))))
+
+
+(defun expand_primitive (srcod poper pargs)
+  (let* (
+	 (pformals (prog_defprimitive-primitive_formals poper))
+	 (pexpansion (prog_defprimitive-primitive_expansion poper))
+	 (pnbformals (length pformals))
+	 (htb (make-hash-table :size (+ (* 2 pnbformals) 3)))
+	 )
+    (if (/= pnbformals (length pargs))
+	(error "formals/args mismatch in primitive ~S" srcod))
+    ;; associate each formal with its actual argument in htb
+    (loop
+      for rk from 0
+      for curform in pformals
+      for curarg in pargs
+      do
+      (let ((curname (cold_any_binding-bname curform)))
+	(setf (gethash curname htb) curarg)
+	))
+    ;; make the expansion
+    (let ( (resexp 
+	    (mapcar 
+	     (lambda (e)
+	       (cond 
+		((numberp e) e)
+		((stringp e) e)
+		((symbolp e) 
+		 (multiple-value-bind 
+		     (symval symhere)
+		     (gethash e htb)
+		   (cond 
+		    ( (stringp symval) (make-prog_cstring :c_str symval)) 
+		    ( symhere symval )
+		    ( t 
+		      (warn "unbound symbol ~S in primitive poper ~S pargs ~S"
+			    e poper pargs)
+		      e ))
+		   ))
+		(t (error "bad element ~S in expansion of ~S" e poper))
+		))
+	     pexpansion))
+	   )
+      (make-prog_chunk :chunk_args resexp :chunk_type  (prog_defprimitive-primitive_type poper))
+      )
+    ))
+
+(defmethod bind_normal_code ((cod prog_primitive) env)
+  (let* ( (poper (prog_primitive-prim_oper cod))
+	  (pargs (prog_primitive-prim_args cod))
+	 )
+    (multiple-value-bind 
+	(normargs pbindseqrev)
+	(normalize_code_sequence pargs env "_PARG_" nil)
+      (values pbindseqrev
+	      (expand_primitive cod poper normargs))
+      )))
+
+
+
+
+(defmethod normalize_call ((cod prog_apply) env)
+  (let ( (afun (prog_apply-appl_fun cod))
+	 (aargs (prog_apply-appl_args cod)) 
+	 (abindseqrev nil) )
+    ;; normalize the applied function if needed
+    (cond  
+     ( (prog_src-p afun)
+       (multiple-value-bind
+	(frbind nfun)
+	(bind_normal_code afun env)
+	(assert (listp frbind))
+	(assert (prog_src-p nfun))
+	(let* (
+	       (fsym (gentemp "_AFUN_"))
+	       (fbind  (make-cold_let_binding
+			:bname fsym :expr nfun))
+	       )
+	  (setq abindseqrev (append frbind abindseqrev))
+	  (push fbind abindseqrev)
+	  (setq afun fsym))))
+     ( (symbolp afun)
+       (setq afun (normalize_symbol afun env)) )
+     ( t
+       (error "bad function to apply in ~s" cod))
+     )
+    ;; normalize the arguments
+    (multiple-value-bind 
+     (normargs pbindseqrev)
+     (normalize_code_sequence aargs env "_FARG_" abindseqrev)
+     (values 
+      (make-prog_apply 
+       :appl_fun afun
+       :appl_args normargs)
+      pbindseqrev
+      ))))
+
+(defmethod bind_normal_code ((cod prog_apply) env)
+  (multiple-value-bind
+      (cod bindrev)
+      (normalize_call cod env)
+    (values bindrev cod)
+  ))
+
+;;; normalize a let (gotten from source code)
+(defmethod bind_normal_code ((cod prog_let) env)
+  (let* ( (lbinds (prog_let-let_bindings cod))
+	  (lbody (prog_let-let_body cod)) 
+	  (newenv (cold_fresh_env env))
+	  (nbinds 
+	   (mapcar 
+	    (lambda (b) 
+	      (let ((nb (copy-cold_let_binding b)))
+		(multiple-value-bind
+		 (pbindrev pbody)
+		 (bind_normal_code (cold_let_binding-expr b) newenv)
+		 (assert (listp pbindrev))
+		 (setf (cold_let_binding-expr nb)
+		       (cold_wrap_let
+			pbindrev
+			pbody))
+		 (cold_put_binding nb newenv)
+		 nb)))
+	    lbinds))
+	  )
+    (multiple-value-bind 
+     (nbody pbindseqrev)
+     (normalize_code_sequence lbody newenv "_LETBODY_" nil)
+;;; since the new bindings are gensymed, no risk of conflict with old ones
+     (values
+      nil
+      (cold_wrap_letseq 
+       (append pbindseqrev (reverse nbinds))
+       nbody)
+      )
+     )))
+
+
+;; normalize an if
+(defmethod bind_normal_code ((cod prog_if) env)
+  (let* ( (icond (prog_if-cond_expr cod))
+	  (ithen (prog_if-then_expr cod))
+	  (ielse (prog_if-else_expr cod)) )
+    (multiple-value-bind 
+     (ncond condbindseqrev)
+     (normalize_code_sequence (list icond) env "_IFCOND_" nil) 
+     ;; if the condition has been gentemp-ed force its binding of type long
+     ;; if it had no type
+     (let ( (nc1 (first ncond)) )
+       (if (symbolp nc1)
+	   (let ( (bc1 (find-if (lambda (b) 
+				  (and (cold_let_binding-p b)
+				       (eq nc1 (cold_any_binding-bname b))))
+				condbindseqrev)) )
+	     (if (cold_typed_binding-p bc1) 
+		 (or (cold_typed_binding-type bc1)
+		     (setf  (cold_typed_binding-type bc1) :long))
+	       ))))
+     (multiple-value-bind
+      (thenrevbind normthen)
+      (bind_normal_code ithen env)
+      (assert (listp thenrevbind))
+      (values
+       condbindseqrev
+       (make-prog_if 
+	:cond_expr (first ncond)
+	:then_expr (cold_wrap_let thenrevbind normthen)
+	:else_expr 
+	(if ielse 
+	    (multiple-value-bind
+	     (elserevbind normelse)
+	     (bind_normal_code ielse env)
+	     (assert (listp elserevbind))
+	     (cold_wrap_let elserevbind normelse))
+	  )
+	))))))
+
+
+;; normalize a forever
+
+(defmethod bind_normal_code ((cod prog_forever) env)
+  (let* ( (ibind (prog_forever-forever_bind cod))
+	  (ibody (prog_forever-forever_body cod)) 
+	  (newenv (cold_fresh_env env)) 
+	  )
+    (cold_put_binding ibind newenv)
+    (multiple-value-bind 
+	(nbody bindseqrev)
+	(normalize_code_sequence ibody newenv "_FOREVERB_" nil)
+	(assert (listp bindseqrev))
+      (values
+       nil
+       (make-prog_forever
+	:forever_bind ibind
+	:forever_body 
+	(cold_wrap_letlist
+	 bindseqrev nbody
+	 ))))))
+    
+
+
+;; normalize an exit
+(defmethod bind_normal_code ((cod prog_exit) env)
+  (let* ( (ibind (prog_exit-exit_bind cod))
+	  (ibody (prog_exit-exit_body cod)) )
+    (multiple-value-bind 
+     (nbody bindseqrev)
+     (normalize_code_sequence ibody env "_EXIT_" nil) 
+     (assert (listp bindseqrev))
+     (values
+      bindseqrev
+      (make-prog_exit 
+       :exit_bind ibind
+       :exit_body nbody
+       )))))
+
+
+
+
+;; normalize a progn
+(defmethod bind_normal_code ((cod prog_progn) env)
+  (let ((ibody (prog_progn-progn_body cod)))
+    (values
+     nil
+     (make-prog_progn
+      :progn_body 
+      (mapcar 
+       (lambda (comp) 
+	 (multiple-value-bind 
+	  (sbind scod)
+	  (bind_normal_code comp env)
+	  (assert (listp sbind))
+	  (cold_wrap_let
+	   sbind scod)
+	  ))
+       ibody)))))
+       
+
+    
+;; normalize a multicall
+(defmethod bind_normal_code ((cod prog_multicall) env)
+  (let ( (iformals (prog_multicall-multicall_formals cod)) ;list of formal bindings
+	 (icall (prog_multicall-multicall_call cod))
+	 (ibody (prog_multicall-multicall_body cod)) 
+	 (newenv (cold_fresh_env env))
+	 )
+    (mapc (lambda (b) (cold_put_binding b newenv)) iformals)
+    (multiple-value-bind 
+     (normcall pcallbindseqrev)
+     ;;; we should normalize only the sequence of args of the call or send
+     ;;; it should stay a call or a send
+     (normalize_call icall env)
+     (assert (or (prog_send-p normcall) (prog_apply-p normcall)))
+     (assert (listp pcallbindseqrev))
+     (multiple-value-bind 
+      (normbody pbodybindseqrev)
+      (normalize_code_sequence ibody newenv "_MULCALLBODY_" nil)
+      (assert (listp pbodybindseqrev))
+      (values 
+       pcallbindseqrev
+       (make-prog_multicall
+	:multicall_formals iformals
+	:multicall_call normcall
+	:multicall_body 
+	(cold_wrap_letlist
+	 pbodybindseqrev normbody
+	 )))))))
+
+
+
+;; normalize a send
+(defmethod normalize_call ((cod prog_send) env)
+  (let ( (isel (prog_send-send_sel cod))
+	 (irecv (prog_send-send_recv cod))
+	 (iargs (prog_send-send_args cod)) )
+    (assert (symbolp isel))
+    (multiple-value-bind 
+     (normrecvargs pbindseqrev)
+     (normalize_code_sequence (cons irecv iargs) env "_SEND_" nil)
+     (let ( (nrecv (first normrecvargs))
+	    (nargs (rest normrecvargs)) 
+	    )
+       (values
+	(make-prog_send
+	 :send_sel (normalize_symbol isel env)
+	 :send_recv nrecv
+	 :send_args nargs)
+	pbindseqrev
+	)))))
+
+(defmethod bind_normal_code ((cod prog_send) env)
+  (multiple-value-bind
+   (nsend pbindseqrev)
+   (normalize_call cod env)
+   (assert (listp pbindseqrev))
+   (values pbindseqrev nsend)))
+
+;;; normalize an unsafe_get_field
+(defmethod bind_normal_code ((cod prog_unsafe_get_field) env)
+  (let ( (ifldname (prog_unsafe_get_field-uget_field cod))
+	 (iobjexpr (prog_unsafe_get_field-uget_obj cod)) )
+    (let ( (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
+      (assert (cold_field_binding-p ifldbind) (ifldbind) 
+	      "invalid fldbind ~S for fldname ~S in unsafe_get_field ~S env ~S <:::bad get_field ~S" 
+	      ifldbind ifldname cod env ifldname)
+      (let ( (fld (cold_field_binding-fieldef ifldbind)) )
+	(multiple-value-bind 
+	 (nobjbind nobjexpr)
+	 (bind_normal_code iobjexpr env)
+	 (assert (listp nobjbind))
+	 (values 
+	  nobjbind
+	  (make-prog_unsafe_get_field
+	   :uget_field fld
+	   :uget_obj nobjexpr)
+	  ))))))
+
+
+;;; normalize an unsafe_put_fields
+(defmethod bind_normal_code ((cod prog_unsafe_put_fields) env)
+  (let ( (iobjexpr (prog_unsafe_put_fields-uput_obj cod))
+	 (ikeys (prog_unsafe_put_fields-uput_keys cod)) 
+	 (nrevkeys nil)
+	 )
+    ;; check key symbols and make the list of fields
+    (let (
+	(fieldlist 
+	 (mapcar (lambda (kpair) 
+	    (let* ( (ifldname (car kpair))
+		    (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
+	      (assert (cold_field_binding-p ifldbind) (ifldbind) 
+		      "invalid fldbind ~S in unsafe_put_fields ~S fldname ~S env ~S" ifldbind cod ifldname env)
+	       (cold_field_binding-fieldef ifldbind)
+	      ))
+	  ikeys))
+	)
+    ;; normalize the object expression
+    (multiple-value-bind
+     (nobjbinds nobjexpr)
+     (bind_normal_code iobjexpr env)
+     ;;; normalize the field expressions
+     (multiple-value-bind
+      (nkeyexprs nkeybinds)
+      (normalize_code_sequence
+       (mapcar #'cdr ikeys)
+       env "_UPUTF_"  nobjbinds)
+      ;;; make the normalized key pairs
+      (mapc 
+       (lambda (fld nexpk)
+	 (push (cons fld nexpk) nrevkeys)
+	 ) fieldlist nkeyexprs)
+      (values
+       nkeybinds
+       (make-prog_unsafe_put_fields
+	:uput_obj nobjexpr
+	:uput_keys (reverse nrevkeys))
+       ))))))
+
+
+
+
+;;; normalize an make_instance
+(defmethod bind_normal_code ((cod prog_make_instance) env)
+  (let ( (iclass (prog_make_instance-mki_class cod))
+	 (ikeys (prog_make_instance-mki_keys cod)) 
+	 (nrevkeys nil)
+	 )
+    ;; check class & key symbols and make the list of fields
+    (let* (
+	   (classbind (cold_find_binding iclass env))
+	   (classdef (if (cold_class_binding-p classbind) 
+			 (cold_class_binding-classdef classbind)
+		       (error "make_instance ~S not a class bind ~S env ~S"
+			      iclass classbind env)))
+	   (fieldlist 
+	    (mapcar (lambda (kpair) 
+		      (let* ( (ifldname (car kpair))
+			      (ifldbind (cold_find_binding (keyword2symbol ifldname) env)) )
+			(assert (cold_field_binding-p ifldbind) (ifldbind) 
+				"invalid fldbind ~S in make_instance ~S for fldname ~S env ~S<:: bad make_instance fieldname ~S~%"
+				ifldbind cod ifldname env ifldname)
+			(let* ( (fld (cold_field_binding-fieldef ifldbind)) 
+				(fldoff (prog_field-field_offset fld))
+				)
+			  (assert (eq (nth fldoff (prog_defclass-class_allfields classdef)) fld)
+				  (fld)
+				  "bad field ~S in make_instance ~S" fld cod)
+			  fld
+			  )
+			))
+		    ikeys))
+	   )
+;;; normalize the field expressions
+      (multiple-value-bind
+       (nkeyexprs nkeybinds)
+       (normalize_code_sequence
+	(mapcar #'cdr ikeys)
+	env "_UMKI_"  nil)
+;;; make the normalized key pairs
+       (mapc 
+	(lambda (fld nexpk)
+	  (push (cons fld nexpk) nrevkeys)
+	  ) fieldlist nkeyexprs)
+       (values
+	nkeybinds
+	(make-prog_make_instance
+	 :mki_class (normalize_symbol iclass env)
+	 :mki_classdef classdef
+	 :mki_keys (reverse nrevkeys))
+	)))))
+
+
+
+;; normalize the body of a lambda or a function
+;; hence put an implicit return on last element
+(defun normalize_body (body env)
+  (assert (cold_compenv-p env))
+  (or (listp body) (error "bad body ~S for normalize_body ~%" body))
+  (multiple-value-bind
+   (nseq nbind)
+   (normalize_code_sequence body env "_BODY_" nil)
+   (assert (listp nbind))
+   (if (listp nseq)
+       (let ( (bl (butlast nseq))
+	      (l  (last nseq)) )
+	 (if (prog_return-p (first l))
+	     (cold_wrap_letseq nbind nseq)
+	   (cold_wrap_letlist
+	    nbind 
+	    (append bl (list (make-prog_return :retexprs l)))
+	    )
+	   )))))
+
+
+
+;;;;;;; normalize a lambda
+(defmethod bind_normal_code ((cod prog_lambda) env)
+  (let* ( (formals (prog_lambda-lambda_formals cod))
+	  (body (prog_lambda-lambda_body cod))
+	  (argbs (prog_lambda-lambda_argbindings cod))
+	  (newenv (cold_fresh_env env))
+	  (ncod (copy-prog_lambda cod))
+	  )
+    (setf (cold_compenv-for newenv) ncod)
+    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
+    (let*( (nbody (normalize_body body newenv))
+	   (nfnam (gentemp "_LAMBDAFUN_"))
+	   (nclosv  (prog_lambda-lambda_closvars ncod))
+	   (nfun (make-prog_defun
+		  :def_name nfnam
+		  :fun_formals formals
+		  :fun_argbindings argbs
+		  :fun_body nbody
+		  :fun_lambda cod
+		  :fun_closvars nclosv))
+	   ;; call normalize_symbol on each closed variable in the lambda
+	   ;; with the side-effect of propagating, if necessary, the closed
+	   ;; variables into the current function
+	   (closvseq (mapcar (lambda (cv) 
+			       (normalize_symbol (prog_closedvar-clv_var cv) env)) 
+			     nclosv))
+	   )
+      (push nfun (compilation-functions this_compilation))
+      (setf (prog_lambda-lambda_body ncod) nbody)
+      (cold_delay
+       "addobjcode lambda"
+       (let ( (cofun (compile_obj nfun newenv)) ) 
+	 (add_objcode cofun)
+	 )
+       )
+      (let( (mkclos 
+	     (make-prog_makeclosure
+	      :mkclos_fun nfun
+	      :mkclos_closvars closvseq)) )
+	(values nil mkclos)
+	))))
+
+
+
+(defmethod bind_normal_code ((cod prog_return) env)
+  (let ( (retargs (prog_return-retexprs cod)) )
+    ;; normalize the arguments
+    (multiple-value-bind 
+     (normargs pbindseqrev)
+     (normalize_code_sequence retargs env "_RETARG_" ())
+     (values pbindseqrev
+	     (make-prog_return
+	      :retexprs normargs)
+	     ))))
+
+	  
+
+
+(defvar normalized_defun nil)
+  
+(defmethod normalize_toplev ((cod prog_defun) env)
+  (let* ( (ncod (copy-prog_defun cod)) 
+	  (fbody (prog_defun-fun_body cod))
+	  (argbs (prog_defun-fun_argbindings cod))
+	  (newenv (cold_fresh_env env))
+	  )
+    (setq normalized_defun cod)
+    (setf (cold_compenv-for newenv) ncod)
+    (mapc  (lambda (b) (cold_put_binding b newenv)) argbs)
+    (let( (nbody (normalize_body fbody newenv)) )
+      (setf (prog_defun-fun_body ncod) nbody))
+    (setq normalized_defun ())
+    ncod
+    ))
+  
+
+
+(defmethod normalize_toplev ((cod prog_definstance) env)
+  (let* ( (ncod (copy-prog_definstance cod)) 
+	  (slots (prog_definstance-inst_slots cod))
+	  (nslots 
+	   (mapcar 
+	    (lambda (s) 
+	      (assert (instance_slot-p s))
+	      (make-instance_slot 
+	       :slot_field (instance_slot-slot_field s)
+	       :slot_value 
+	       (multiple-value-bind
+		   (sbind sexpr)
+		   (bind_normal_code 
+		    (instance_slot-slot_value s)
+		    env)
+		 (cold_wrap_let sbind sexpr))))
+	    slots)) )
+    (setf (prog_definstance-inst_slots ncod) nslots)
+    ncod)
+  )
+
+(defmethod normalize_toplev ((cod prog_defselector) env)
+  (let* ( (ncod (copy-prog_defselector cod)) 
+	  (slots (prog_defselector-inst_slots cod))
+	  (nslots 
+	   (mapcar 
+	    (lambda (s) 
+	      (assert (instance_slot-p s))
+	      (make-instance_slot 
+	       :slot_field (instance_slot-slot_field s)
+	       :slot_value 
+	       (multiple-value-bind
+		   (sbind sexpr)
+		   (bind_normal_code 
+		    (instance_slot-slot_value s)
+		    env)
+		 (cold_wrap_let sbind sexpr))))
+	    slots)) )
+    (setf (prog_defselector-inst_slots ncod) nslots)
+    ncod)
+  )
+
+;;;;;;;;;;;; compile to object
+(defstruct compilation
+  functions				;list of prog- functions
+  currout				;current routine
+  initrout				;initialization routine
+  revobjcode				;generated object code reversed list
+  cdata					;constructed data
+  symboldict				;dictonnary of gererated symbols
+)
+
+
+
+;; sometimes we need to take the length of a stuff and round it to 1 if it is empty
+(defun my_length_gt_1 (s) 
+  (let  ( (l (length s)) )
+    (if (> l 0) l 1)))
+
+(defstruct obj_instr
+)
+
+(defgeneric output_ccode (obj str)
+  (:documentation "output C code from Basilys code")
+)
+
+(defgeneric output_cdecl (obj str)
+  (:documentation "output C declaration from Basilys code")
+)
+
+(defmethod output_ccode ((obj t) str)
+  (error "invalid arg (type ~A) to output_ccode ~S" (type-of obj)  obj)
+)
+
+(defmethod output_ccode ((obj symbol) str)
+  (format str "/*@Symb*/((void*)(BASILYSG(~S)))" obj))
+
+(defmethod output_ccode ((obj null) str)
+  (format str "/*@Nil*/NULL"))
+
+(defmethod output_ccode ((obj string) str)
+  (format str "/*@String*/~S" obj))
+
+(defmethod output_ccode ((obj integer) str)
+  (format str "/*@Integer*/~S" obj))
+
+(defmethod output_cdecl ((obj t) str)
+  (error "unexpected output_cdecl (type ~A) ~S~%" (type-of obj) obj)
+  (format_c_comment str "**@declobj t![~A]~%~S~%**" (type-of obj) obj))
+
+(defstruct (obj_get_arguments (:include obj_instr))
+  instrs
+)
+
+(defstruct (obj_verbatim)
+  vstr)
+
+(defstruct (obj_verbatiminstr (:include obj_instr))
+  vstr)
+
+(defmethod  print-object ((ob obj_verbatim) st)
+  (let ((*print-circle* nil))
+  (format st "{ObVerb ~S}" (obj_verbatim-vstr ob))))
+
+(defmethod output_ccode ((obj obj_verbatim) str)
+  (write-string (obj_verbatim-vstr obj) str)
+)
+
+(defmethod  print-object ((ob obj_verbatiminstr) st)
+  (let ((*print-circle* nil))
+  (format st "{ObVerbIns ~S}" (obj_verbatiminstr-vstr ob))))
+
+(defmethod output_ccode ((obj obj_verbatiminstr) str)
+  (write-string (obj_verbatiminstr-vstr obj) str)
+)
+
+(defstruct (obj_cstring)
+  obcstr)
+
+(defmethod output_ccode ((obj obj_cstring) str)
+  (let ( (cstri (obj_cstring-obcstr obj)) 
+	 )
+    (format_c_comment str "obj_cstring ~S" cstri)
+    (write-string " \"" str)
+    (map nil 
+	 (lambda (c) 
+	   (case c
+		 (#\Newline (write-string "\\n" str))
+		 (#\Tab  (write-string "\\t" str))
+		 (#\\ (write-string "\\\\" str))
+		 (#\' (write-string "\\'" str))
+		 (#\" (write-string "\\\"" str))
+		 (otherwise (if (standard-char-p c)
+				(write-char c str)
+			      (format str "\\x~2,'0x" (char-code c))))
+		 )
+	   )
+	 cstri)
+    (write-string "\" " str)
+    ))
+
+
+(defmethod output_ccode ((obj prog_src) str)
+  (format_c_comment str "~%*** progsrc ~S ***~%~%" obj))
+
+(defgeneric query_ctype (obj)
+  (:documentation "query type of C code")
+)
+
+(defmethod query_ctype ((obj t))
+nil)
+
+(defgeneric put_destination (obj dest)
+  (:documentation "set the destination of C code from Basilys code & return nil or a new objectocde")
+)
+
+(defgeneric get_destination (obj)
+  (:documentation "retrieve the destination of C code from Basilys code")
+)
+
+(defmethod put_destination ((obj t) dest)
+;  (warn "default put_destination obj ~S dest ~S" obj dest)
+  (if (prog_src-p obj) (error "put_destination prog_src obj ~S" obj))
+  (build_obj_compute
+   dest
+   (list obj)
+   (query_ctype obj))
+)
+
+(defmethod put_destination ((obj integer) dest)
+  (build_obj_compute
+   dest
+   (list obj)
+   :long)
+)
+
+(defmethod put_destination ((obj string) dest)
+  (error "put_destination stringobj ~S dest ~S" obj dest)
+  (build_obj_compute
+   dest
+  (list obj)
+  nil)
+)
+
+(defmethod get_destination ((obj t))
+  nil					;do nothing by default
+)
+
+(defmethod output_ccode ((obj cons) str)
+  (format str "/*@list ~d*/ " (length obj))
+  (mapc (lambda (o) 
+	  (format str "~%")
+	  (output_ccode o str)) 
+	obj)
+  (format str "/*@endlist ~d*/ " (length obj)))
+
+(defmethod output_ccode ((obj obj_get_arguments) str)
+  (let (( instrs (obj_get_arguments-instrs obj)))
+    (format str "/*obj_get_arguments ~d*/~%" (length instrs))
+    (mapc (lambda (i) (format str "~%") (output_ccode i str)) instrs)
+    (format str " goto lab_endargs;~%")
+    (format str "lab_endargs: ;~%")
+    )
+)
+
+
+(defstruct  (obj_clearptr (:include obj_instr))
+  clrptrvar
+)
+
+(defmethod output_ccode ((obj obj_clearptr) str)
+  (format str "/*clearptr*/ ")
+  (output_ccode (obj_clearptr-clrptrvar obj) str)
+  (format str " = NULL;~%")
+)
+
+(defstruct  (obj_clearlong (:include obj_instr))
+  clrlongvar
+)
+
+(defmethod output_ccode ((obj obj_clearlong) str)
+  (format str "/*clearlong*/ ")
+  (output_ccode (obj_clearlong-clrlongvar obj) str)
+  (format str " = 0L;~%")
+)
+
+
+(defstruct (obj_data)
+  discr					;the discriminant
+  comname				;comment name
+  )
+
+
+;; add a data to the constdata pool of the compilation; so append the
+;; data to cdata, create a cdata binding for it an a pointerobjvar for
+;; it in the initial routine
+(defun add_cdata (da &optional why)
+  (assert (listp  (compilation-cdata this_compilation)))
+  (and (listp da) (error "bad list cdata ~S" da))
+  (assert (obj_data-p da) (da) "bad cdata ~S" da)
+  (assert (not (member da (compilation-cdata this_compilation))))
+  (push da (compilation-cdata this_compilation))
+  (assert (listp  (compilation-cdata this_compilation)))
+  (let* ( (nbdata (length  (compilation-cdata this_compilation)))
+	  (initrout (compilation-initrout this_compilation))
+	  (dbind  (make-cold_cdata_binding 
+			   :bname (gentemp "CDATA_")
+			   :type :value
+			   :cdata da)) 
+	  (ovar (newobjptrvar initrout dbind 
+			   (if why 
+			       (concatenate 'string "addCdata " (string why))
+			     "added cdata"))) )  
+    (setf (gethash da (obj_initroutine-inirou_datarankdict initrout)) nbdata)
+    (routine_link_data2ptr initrout da ovar)
+    )
+  ;; (format *error-output* "add_cdata da ~S~%" da)
+  da
+  )
+
+(defun add_objcode (ob)
+  (assert (listp  (compilation-revobjcode this_compilation)))
+  (assert (obj_routine-p ob) (ob) "adding bad objcode ~S" ob)
+  (push ob (compilation-revobjcode this_compilation))
+  (assert (listp  (compilation-revobjcode this_compilation)))
+  nil
+)
+
+;(defun put_progdata (pro &optional datagetfun)
+;  (assert (prog_src-p pro) (pro) "put bad progdata ~S" pro)
+;  (or  (gethash pro (compilation-progdict this_compilation))
+;       (if datagetfun
+;	   (let ((data (apply datagetfun (list pro))))
+;	     (assert (obj_data-p data) (data) "bad computed data ~S for progdata ~S" data pro)
+;	     (setf (gethash pro  (compilation-progdict this_compilation))
+;		   data)
+;	     (or (currout_data2ptr data) (add_cdata data))
+;	     data
+;	     ))))
+;
+;(defun progdata (pro)
+; (gethash pro (compilation-progdict this_compilation)))
+;
+;(defun checked_progdata (pro)
+;  (or  (gethash pro (compilation-progdict this_compilation))
+;       (error "prog without data ~S" pro)))
+;
+
+(defmethod output_ccode ((obj obj_data) str)
+  (format str " /*-*ccode objdata ~S */ " (obj_data-comname obj))
+  (let ( (optr (currout_data2ptr obj)) )
+    (assert optr (obj optr) "output_ccode data ~S without ptr" obj)
+    (output_ccode optr str))
+;  (finish-output str)
+)
+
+(defgeneric output_cassign (obda str)
+  (:documentation "output the code to assign the data"))
+
+(defgeneric output_cinit (obda str)
+  (:documentation "output the code to initialize the data"))
+
+(defgeneric output_cfill (obda str)
+  (:documentation "output the code to fill the initialized data"))
+
+(defgeneric output_cverify (obda str)
+  (:documentation "output the code to verify the initialized data"))
+
+(defgeneric output_cref (obda str)
+  (:documentation "output the code to reference the data"))
+
+(defmethod output_cassign ((obda obj_data) str)
+  (let ( (cmsg (with-output-to-string 
+		(s) 
+		(format s "cassign/data cleared ~S #~d [~S]"
+			(obj_data-comname obda) (initrout_rank obda) (type-of obda)))) )
+    (format str "basilys_assertmsg(~a, NULL=="
+	    (str2cstr cmsg)))
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ");~%")
+  (format str "/*cassign data ~S #~d [~S] */~%"
+	  (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (output_ccode (currout_data2ptr obda) str)
+  (format str " = (void*) (&cdat->inidat_~d_);~%" (initrout_rank obda))
+  (format str "#if COLD_BASILYS_DEBUG~%")
+  (format str " debugeprintf(\" %s %p @%d\", ")
+  (write-string 
+   (str2cstr 
+    (with-output-to-string (s)
+			   (format s "cassign data ~S #~d [~S]"
+				     (obj_data-comname obda) 
+				     (initrout_rank obda) 
+				     (type-of obda))))
+   str)
+  (format str ", (void*) (&cdat->inidat_~d_), " (initrout_rank obda))
+  (format str " (int)offsetof(cdata_t, inidat_~d_));~%"  (initrout_rank obda))
+  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
+  )
+
+
+(defmethod output_cinit ((obda obj_data) str)	
+  (finish-output str)
+  (error "cannot output_cinit objdata ~S~%" obda)
+)
+
+
+(defmethod output_cfill ((obda obj_data) str)	
+  (finish-output str)
+  (error "cannot output_cfill objdata ~S~%" obda)
+)
+
+
+
+(defmethod output_cref ((obda obj_data) str)		
+  (format str " /*cref ~S [~S] #~d*/" (obj_data-comname obda) (type-of obda) (initrout_rank obda))
+  (format str " ((void*) (&cdat->inidat_~d_)) " (initrout_rank obda))
+;  (finish-output str)
+)
+
+(defstruct (obj_dataclosure (:include obj_data))
+  rout					;the routine
+  clodata				;closed data
+  )
+
+(defmethod output_ccode ((obj obj_dataclosure) str)
+  (format str " /*-*ccode objdataclosure ~S:*/ " (obj_data-comname obj))
+  (output_ccode (currout_data2ptr obj) str)
+;  (finish-output str)
+)
+
+(defmethod output_cverify ((obda obj_dataclosure) str)	
+;  (finish-output str)
+  (format str "/*cverify dataclosure ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (format str "basilys_assertmsg(\"cverify dataclosure ~S #~d\", basilys_magic_discr((" 
+	  (obj_data-comname obda) (initrout_rank obda))
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ")) == OBMAG_CLOSURE);~%")
+)
+
+(defmethod  print-object ((ob obj_dataclosure) st)
+  (let ( (obcna (obj_data-comname ob))
+	 (dis (obj_data-discr ob))
+	 (rou (obj_dataclosure-rout ob))
+	 (cld (obj_dataclosure-clodata ob)) )
+    (if (obj_routine-p rou)
+	(format st "#{ObjDataClosure ~S discr=~S rout/~a clodata=~S}"
+		obcna dis (prog_defun-def_name (obj_routine-pfun rou)) cld)
+      (call-next-method ob st)
+	  ))
+)
+
+(defstruct (obj_dataroutine (:include obj_data))
+  rout					;the routine
+  roudata				;routine data (reversed order), ie quoted constants
+)
+
+
+
+(defmethod print-object ((ob obj_dataroutine) st)
+  (let ( (obcna (obj_data-comname ob))
+	 (pvar (currout_data2ptr ob))
+	 (dis (obj_data-discr ob))
+	 (rou (obj_dataroutine-rout ob))
+	 (rd (obj_dataroutine-roudata ob)) )
+    (if (obj_routine-p rou)
+	(format st "#{ObjDataRoutine ~S ptrva=~S discr=~S rout/~a roudata*~d=~S}"
+		obcna pvar dis (prog_defun-def_name (obj_routine-pfun rou)) (length rd) rd)
+      (call-next-method ob st)
+	  ))
+)
+
+
+(defmethod output_ccode ((obj obj_dataroutine) str)
+  (format str " /*-*ccode objdataroutine ~S:*/ " (obj_data-comname obj))
+  (output_ccode (currout_data2ptr obj) str)
+;  (finish-output str)
+)
+
+(defmethod output_cverify ((obda obj_dataroutine) str)	
+;  (finish-output str)
+  (format str "/*cverify dataroutine ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (format str "basilys_assertmsg(\"cverify dataroutine ~S #~d\", basilys_magic_discr(("
+	  (obj_data-comname obda) (initrout_rank obda))
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ")) == OBMAG_ROUTINE);~%")
+)
+
+(defstruct (obj_datainstance (:include obj_data))
+  predef				;name of predefined rank or nil
+  objnum				;number (maybe magic) in instance
+  slots					;list of slot values
+)
+
+(defmethod  print-object ((ob obj_datainstance) st)
+  (let ( (obcna (obj_data-comname ob))
+	 (obdiscr (obj_data-discr ob))
+	 (obpredef (obj_datainstance-predef ob))
+	 (obnum (obj_datainstance-objnum ob))
+	 (obslots (obj_datainstance-slots ob)) )
+    (if (obj_datainstance-p obdiscr)
+	(progn
+	  (format st "#{ObjDataInst ~S Discr:~S" obcna (obj_data-comname obdiscr))
+	  (if obpredef (format st " Predef:~S" obpredef))
+	  (if obnum (format st " ObjNum:~S" obnum))
+	  (if obslots (format st " Slots:~S" obslots))
+	  )
+      (call-next-method ob st)
+      )))
+
+(defmethod output_ccode ((obj obj_datainstance) str)
+  (format str " /*-*ccode objdatainstance ~S :*/ " (obj_data-comname obj))
+  (let ( (op (currout_data2ptr obj)) )
+    (or op (error "output_ccode obj datainst ~S without data2ptr" obj))
+    (output_ccode op str)
+;    (finish-output str)
+    ))
+
+(defmethod output_cverify ((obda obj_datainstance) str)	
+;  (finish-output str)
+  (format str "/*cverify datainstance ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (format str "basilys_assertmsg(\"cverify  datainstance ~S #~d\", basilys_magic_discr(("
+	  (obj_data-comname obda) (initrout_rank obda))
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ")) == OBMAG_OBJECT);~%")
+)
+
+(defstruct (obj_datamultiple (:include obj_data))
+  values
+)
+
+(defstruct (obj_datastring (:include obj_data))
+  string
+)
+
+(defstruct (obj_dataqsymbol (:include obj_data))
+  qsymb)
+
+(defstruct (obj_dataqkeyword (:include obj_data))
+  qkeyword)
+	
+;;;;;; quoted symbol data
+(defmethod output_cdecl ((obj obj_dataqsymbol) str)
+  (format str "/*cdecl dataqsymbol ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+  (format str "char* iniqsymb_~d;~%"  (initrout_rank obj))
+  )
+	   
+(defmethod output_cassign ((obj obj_dataqsymbol) str)
+  (format str "/*cassign dataqsymbol ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+  (output_ccode (currout_data2ptr obj) str)
+  (format str " = basilysgc_new_symbol(~a);~%" (str2cstr (string (obj_dataqsymbol-qsymb obj))))
+  (format str "#if COLD_BASILYS_DEBUG~%")
+  (format str " debugeprintf(\" quoted symbol ~S @%p\","  (obj_dataqsymbol-qsymb obj))
+  (output_ccode (currout_data2ptr obj) str)
+  (format str ");~%")
+  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
+)	   
+
+(defmethod output_cinit ((obj obj_dataqsymbol) str)
+  (format str "/*cinit dataqsymbol ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+  (format str " cdat->iniqsymb_~d = ~a;~%"  (initrout_rank obj) 
+	  (str2cstr  (string (obj_dataqsymbol-qsymb obj))))
+)
+
+(defmethod output_cfill ((obj obj_dataqsymbol) str)
+  (format str "/*no cfill dataqsymbol ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+)
+
+(defmethod output_cref ((obj obj_dataqsymbol) str)
+  (format str "/*no cref dataqsymbol ~S #~d [~S] - '~S*/~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+)
+
+(defmethod output_cverify ((obj obj_dataqsymbol) str)
+  (format str "/*no cverify dataqsymbol ~S #~d [~S] - '~S*/~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqsymbol-qsymb obj))
+)
+
+
+
+;;;;;;;; quoted keyword data		     
+(defmethod output_cdecl ((obj obj_dataqkeyword) str)
+  (format str "/*cdecl dataqkeyword ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+  (format str "char* iniqkey_~d;~%"  (initrout_rank obj))
+  )
+	   
+(defmethod output_cassign ((obj obj_dataqkeyword) str)
+  (format str "/*cassign dataqkeyword ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+  (output_ccode (currout_data2ptr obj) str)
+  (format str " = basilysgc_new_keyword(~a);~%" (str2cstr (string (obj_dataqkeyword-qkeyword obj))))
+  (format str "#if COLD_BASILYS_DEBUG~%")
+  (format str " debugeprintf(\" quoted keyword ~S @%p\"," (obj_dataqkeyword-qkeyword obj))
+  (output_ccode (currout_data2ptr obj) str)
+  (format str ");~%")
+  (format str "#endif /*COLD_BASILYS_DEBUG*/~%")
+)	   
+
+(defmethod output_cinit ((obj obj_dataqkeyword) str)
+  (format str "/*cinit dataqkeyword ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+  (format str " cdat->iniqkey_~d = ~a;~%"  (initrout_rank obj) 
+	  (str2cstr  (string (obj_dataqkeyword-qkeyword obj))))
+)
+
+(defmethod output_cfill ((obj obj_dataqkeyword) str)
+  (format str "/*no cfill dataqkeyword ~S #~d [~S] - '~S */~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+)
+
+(defmethod output_cref ((obj obj_dataqkeyword) str)
+  (format str "/*no cref dataqkeyword ~S #~d [~S] - '~S*/~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+)
+
+(defmethod output_cverify ((obj obj_dataqkeyword) str)
+  (format str "/*no cverify dataqkeyword ~S #~d [~S] - '~S*/~%"
+	  (obj_data-comname obj) (initrout_rank obj) (type-of obj) (obj_dataqkeyword-qkeyword obj))
+)
+
+;;;;;;;;;;;;;;;
+
+
+(defmethod output_cdecl ((obj obj_dataclosure) str)
+  (format str "/*- decl dataclosure ~S -*/~%" (obj_data-comname obj))
+  (format str " struct BASILYS_CLOSURE_STRUCT(~d) inidat_~d_;~%" 
+	  (my_length_gt_1 (obj_dataclosure-clodata obj)) (initrout_rank obj))
+)
+
+
+(defmethod output_cinit ((obj obj_dataclosure) str)
+    (format str "/*- init dataclosure ~S-*/~%" (obj_data-comname obj))
+    (let ( (irk (initrout_rank obj)) )
+      (assert (integerp irk))
+      (format str " cdat->inidat_~d_.discr = " irk)
+      (output_ccode (obj_data-discr obj) str) 
+      (format str ";~%")
+      (format str " cdat->inidat_~d_.rout = " irk)
+      (output_cref (obj_routine-datarout (obj_dataclosure-rout obj)) str)
+      (format str ";~%")
+      (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataclosure-clodata obj)))
+))
+
+
+(defmethod output_cfill ((obj obj_dataclosure) str)
+  (let ( (ov  (currout_data2ptr obj))
+	 )
+    (format str "/*- cfill dataclosure ~S -*/~%" (obj_data-comname obj))
+    (format str " basilys_assertmsg(\"cfill dataclosure ~S\", basilys_magic_discr((" (obj_data-comname obj))
+    (output_ccode ov str)
+    (format str ")) == OBMAG_CLOSURE);~%")
+    (let ( (nbd  (length  (obj_dataclosure-clodata obj))) )
+      (if (> nbd 0) 
+	  (progn
+	    (format str " basilys_assertmsg(\"cfill len dataclosure ~S\", ((basilysclosure_ptr_t)("
+		    (obj_data-comname obj))
+	    (output_ccode ov str)
+	    (format str "))->nbval >= ~d);~%" nbd))))
+    (loop
+     for crk from 0
+     for cda in (obj_dataclosure-clodata obj)
+     do
+     (format str " ((basilysclosure_ptr_t)(")
+     (output_ccode ov str)
+     (format str "))->tabval[~d] = " crk)
+     (output_ccode cda str)
+     (format str ";~%")
+     )
+     (format str " basilysgc_touch(")
+     (output_ccode ov str)
+     (format str ");~%")     
+  ))
+
+(defmethod output_cdecl ((obj obj_dataroutine) str)
+    (let ( (irk (initrout_rank obj)) )
+  (format str "/*- decl dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
+      (format str " struct BASILYS_ROUTINE_STRUCT(~d) inidat_~d_;~%" 
+	      (my_length_gt_1 (obj_dataroutine-roudata obj)) irk)
+  ))
+
+(defmethod output_cinit ((obj obj_dataroutine) str)
+  (let ( (irk (initrout_rank obj)) )
+    (format str "/*- init dataroutine ~S #~d-*/~%" (obj_data-comname obj) irk)
+    (format str " cdat->inidat_~d_.discr = " irk)
+    (output_ccode (obj_data-discr obj) str) 
+    (format str ";~%")
+    (format str " strncpy(cdat->inidat_~d_.routdescr, \"~S\", BASILYS_ROUTDESCR_LEN-1);~%" 
+ 	    irk (prog_defun-def_name (obj_routine-pfun (obj_dataroutine-rout obj))))
+    (format str " *(basilysroutfun_t **)(cdat->inidat_~d_.routaddr) = ~a;~%"
+	    irk (routinecname (obj_dataroutine-rout obj)))
+    (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_dataroutine-roudata obj)))
+    ))
+  
+
+(defmethod output_cfill ((obj obj_dataroutine) str)
+  (let (
+	(op (currout_data2ptr obj))
+	(irk (initrout_rank obj))
+	)
+    (format str "/*-cfill dataroutine ~S #~d -*/~%" (obj_data-comname obj) irk)
+    (format str " basilys_assertmsg(\"cfill dataroutine ~S #~d\", basilys_magic_discr((" (obj_data-comname obj) irk)
+    (output_ccode op str)
+    (format str ")) == OBMAG_ROUTINE);~%")
+    (let ( (nbd  (length (obj_dataroutine-roudata obj))) )
+      (if (> nbd 0) 
+	  (progn 
+	    (format str " gcc_assert(((basilysroutine_ptr_t)(")
+	    (output_ccode op str)
+	    (format str "))->nbval >= ~d);~%" nbd))))
+    (loop
+     for crk from 0
+     for cda in (reverse (obj_dataroutine-roudata obj))
+     do
+     (format str "((basilysroutine_ptr_t)(")
+     (output_ccode op str)
+     (format str "))->tabval[~d] = " crk)
+     (output_ccode cda str)
+     (format str ";~%")
+     )
+    (format str " basilysgc_touch(")
+    (output_ccode op str)
+    (format str ");~%")
+;    (finish-output str)
+    ))
+
+(defmethod output_cdecl ((obj obj_datainstance) str)
+  (let ( (irk (initrout_rank obj)) )
+  (format str "/*- decl datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
+  (format str " struct BASILYS_OBJECT_STRUCT(~d) inidat_~d_;~%" 
+	  (my_length_gt_1 (obj_datainstance-slots obj)) irk)
+;  (finish-output str)
+))
+
+
+(defmethod output_cinit ((obj obj_datainstance) str)
+  (let ( (irk (initrout_rank obj)) )
+    (format str "/*- init datainstance ~S #~d-*/~%" (obj_data-comname obj) irk)
+   (format str " cdat->inidat_~d_.obj_class = " irk)
+   (output_ccode (obj_data-discr obj) str) 
+   (format str ";~%")
+   (format str " cdat->inidat_~d_.obj_len = ~d;~%" irk (length (obj_datainstance-slots obj)));
+   (format str " cdat->inidat_~d_.obj_vartab =  cdat->inidat_~d_.obj__tabfields; ~%" irk irk)
+   ;; 134217728 is 2**27 so the hash is >0
+   (format str " cdat->inidat_~d_.obj_hash = ~d;~%" irk (+ 1 (random 134217728)))
+   (let ((onu (obj_datainstance-objnum obj)))
+     (if onu 
+	  (format str " cdat->inidat_~d_.obj_num = ~S;~%" irk onu)
+	)))
+    )
+
+(defmethod output_cassign ((obda obj_datainstance) str)
+  (let ( (irk (initrout_rank obda)) )
+    (format str "/*cassign datainstance ~S #~d*/" (obj_data-comname obda) irk)
+    (format str "basilys_assertmsg(\"cassign datainstance ~S #~d cleared\", NULL=="
+	    (obj_data-comname obda) irk)
+    (output_ccode (currout_data2ptr obda) str)
+    (format str ");~%")
+    (let ((prd (obj_datainstance-predef obda)))
+      (cond (( null prd) )
+	    ((symbolp prd) (format str "/*predef sym*/BASILYSG(~S) = " prd))
+	    ((integerp prd) (format str "/*predef num*/basilys_globarr[~d] = " prd))
+	    (t  (error "bad predef ~S in obj_datainstance ~S" prd obda)))
+      )
+    (output_ccode (currout_data2ptr obda) str)
+    (format str " = (void*) (&cdat->inidat_~d_);~%" irk)
+;    (finish-output str)
+    ))
+
+(defmethod output_cfill  ((obda obj_datainstance) str)
+  (let ( (sl  (obj_datainstance-slots obda))
+	 (ov  (currout_data2ptr obda))
+	 (irk (initrout_rank obda)) 
+	 )
+    (format str "/*cfill datainstance ~S #~d */~%" (obj_data-comname obda) irk)
+    (format str " basilys_assertmsg(\"cfill datainstance ~S #~d\", basilys_magic_discr((" 
+	    (obj_data-comname obda) irk)
+    (output_ccode ov str)
+    (format str " )) == OBMAG_OBJECT);~%")
+    (format str " basilys_assertmsg(\"cfill len datainstance ~S #~d\",  ((basilysobject_ptr_t)("
+	    (obj_data-comname obda) irk)
+    (output_ccode ov str)
+    (format str "))->obj_len >= ~d);~%" (length sl))
+;    (finish-output str)
+    (if sl
+	(loop
+	 for crk from 0
+	 for csl in sl
+	 when csl		       ;don't bother filling nil slots
+	 do
+;	 (finish-output str)
+	 ;; this is a dirty hack, csl should have cold_tempslot_var as
+	 ;; destination but some make-obj_datainstance don't do it.
+	 ;; if I wanted to code properly I would correct the callers.
+	 (or  (get_destination csl) 
+	      (let ((ncsl (put_destination csl cold_tempslot_var)))
+		(assert ncsl)
+		(setq csl ncsl)))
+	 (assert (eq (get_destination csl) cold_tempslot_var))
+	 (output_ccode csl str)
+	 (format str ";~%")
+	 (format str "((basilysobject_ptr_t)(")
+	 (output_ccode ov str)
+	 (format str ")) ->obj_vartab[~d] = " crk)
+	 (output_ccode cold_tempslot_var str)
+	 (format str ";~%")
+	 ))
+    (format str " basilysgc_touch(")
+    (output_ccode ov str)
+    (format str ");~%")
+;    (finish-output str)
+    ))
+
+(defmethod output_cdecl ((obj obj_datamultiple) str)
+  (let ( (irk (initrout_rank obj)) )
+  (format str "/*- decl datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
+  (format str " struct BASILYS_MULTIPLE_STRUCT(~d) inidat_~d_;~%" 
+	  (my_length_gt_1 (obj_datamultiple-values obj)) irk)
+  ))
+
+(defmethod output_cinit ((obj obj_datamultiple) str)
+  (let ( (irk (initrout_rank obj)) )
+  (format str "/*- init datamultiple ~S #~d-*/~%" (obj_data-comname obj) irk)
+   (format str " cdat->inidat_~d_.discr = " irk)
+   (output_ccode (obj_data-discr obj) str) 
+   (format str ";~%")
+   (format str " cdat->inidat_~d_.nbval = ~d;~%" irk (length (obj_datamultiple-values obj)))
+))
+
+(defmethod output_cfill ((obj obj_datamultiple) str)
+  (let ( (op (currout_data2ptr obj))
+	 (irk (initrout_rank obj))  )
+    (format str "/*- fill datamultiple ~S #~d -*/~%" (obj_data-comname obj) irk)
+    (format str " gcc_assert(basilys_magic_discr((")
+    (output_ccode op str)
+    (format str ")) == OBMAG_MULTIPLE);~%")
+    (let ( (nbd  (length  (obj_datamultiple-values obj))) )
+      (if (> nbd 0)
+	  (progn
+	    (format str " gcc_assert(((basilysmultiple_ptr_t)(")
+	    (output_ccode op str)
+	    (format str "))->nbval >= ~d);~%" nbd))))
+;    (finish-output str)
+    (loop
+     for crk from 0
+     for cda in (obj_datamultiple-values obj)
+     do
+     (format str "((basilysmultiple_ptr_t)(")
+     (output_ccode op str)
+     (format str "))->tabval[~d] = " crk)
+     (output_ccode cda str)
+     (format str ";~%")
+     )
+     (format str " basilysgc_touch(")
+     (output_ccode op str)
+     (format str ");~%")
+;    (finish-output str)
+    ))
+
+(defmethod output_cverify ((obda obj_datamultiple) str)	
+;  (finish-output str)
+  (format str "/*cverify datamultiple ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (format str "gcc_assert(basilys_magic_discr((")
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ")) == OBMAG_MULTIPLE);~%")
+)
+
+(defmethod output_cdecl ((obj obj_datastring) str)
+;  (finish-output str)
+  (let ( (irk (initrout_rank obj))  )
+    (format str "/*- decl datastring ~S #~d -*/~%" (obj_data-comname obj) irk)
+    (format str " struct BASILYS_STRING_STRUCT(~d) inidat_~d_;~%" 
+      (my_length_gt_1 (obj_datastring-string obj)) irk)
+))
+
+
+(defmethod output_cinit ((obj obj_datastring) str)
+;  (finish-output str)
+  (let ( (irk (initrout_rank obj))  )
+    (format str "/*- init datastring ~S #~d-*/~%" (obj_data-comname obj) irk)
+    (format str " cdat->inidat_~d_.discr = " irk)
+    (output_ccode (obj_data-discr obj) str) 
+    (format str ";~%")
+    (format str " strcpy(cdat->inidat_~d_.val, ~s);~%" irk (obj_datastring-string obj))
+;    (finish-output str)
+    ))
+
+(defmethod output_cfill ((obj obj_datastring) str)
+  (finish-output str)
+)
+
+(defmethod output_cverify ((obda obj_datastring) str)	
+;  (finish-output str)
+  (format str "/*cverify datastring ~S #~d [~S] */~%" (obj_data-comname obda) (initrout_rank obda) (type-of obda))
+  (format str "gcc_assert(basilys_magic_discr((")
+  (output_ccode (currout_data2ptr obda) str)
+  (format str ")) == OBMAG_STRING);~%")
+)
+
+(defstruct (obj_getptrarg_instr (:include obj_instr))
+  dest
+  rk
+)
+
+(defmethod output_ccode ((obj obj_getptrarg_instr) str)
+  (format str "/*-*obj_getptrarg_instr*/~%")
+  (let ( (dest (obj_getptrarg_instr-dest obj))
+	 (rk  (obj_getptrarg_instr-rk obj)) )
+    (if (= rk 0) 
+	(progn 
+	  (format str "basilys_checked_assign(/*ptrarg0*/")
+	  (output_ccode dest str)
+	  (format str " = firstargp_);")
+	  )
+      (progn 
+	(format str "if (xargdescr_[~d] == BPAR_PTR)~% " (- rk 1))
+	(format str "basilys_checked_assign(/*ptrarg~d*/" rk)
+	(output_ccode dest str)
+	(format str
+		" = *(xargtab_[~d].bp_aptr));~% else goto lab_endargs;~%"
+		(- rk 1))
+	)
+      )
+;    (finish-output str)
+    ))
+
+(defstruct (obj_getlongarg_instr (:include obj_instr))
+  dest
+  rk
+)
+
+(defmethod output_ccode ((obj obj_getlongarg_instr) str)
+  (format_c_comment str "*obj_getlongarg_instr ~S*~%" obj)
+  (let ( (dest (obj_getlongarg_instr-dest obj))
+	 (rk  (obj_getlongarg_instr-rk obj)) )
+    (if (= rk 0) 
+	(error "long arg cannot be first ~S" obj))
+    (format str "if (xargdescr_[~d] == BPAR_LONG)~% " (- rk 1))
+    (output_ccode dest str)
+    (format str " = xargtab_[~d].bp_long;~% else goto lab_endargs;~%"
+	    (- rk 1))
+;    (finish-output str)
+    )
+  )
+
+
+;;; actually an obj_compute may have several destination (for example
+;;; for a setq whose value is used)
+    
+(defstruct (obj_compute (:include obj_instr))
+  dest				      ;last destination
+  sons					;either strings or expr or atoms
+  otype					;type
+  compserial				;unique serial number
+  )
+
+(defvar compute_serial_count 0)
+
+(defun build_obj_compute (dest sons otype)
+  (assert (listp sons))
+  (if (some (function prog_src-p) sons) 
+      (error "build_obj_compute bad sons {prog_src} ~S" sons))
+  (if (some (function obj_instr-p) sons) 
+      (error "build_obj_compute bad sons {obj_instr} ~S" sons))
+  (incf compute_serial_count)
+  (make-obj_compute :dest dest 
+		    :sons (if dest (append (list dest " = ") sons) sons) 
+		    :otype otype :compserial compute_serial_count)
+)
+
+
+;;; set a closed variable
+(defstruct (obj_closetq (:include obj_instr))
+  cldest				;closed destination
+  val)
+
+;;; obj_vars are variables (eg pointers, longs...) in the current stack frame
+(defstruct obj_var
+  vbind					;the binding defing the program variable
+  voffset				;the offset or index in the C frame
+  vrout					;the routine containing the variable
+  vwhy					;the reason why this stuff has been made
+  vfree					;set when freed in the curframe
+);; obj_ptrvar & obj_longvar are actually the relevant subclasses see
+;; also obj_closedvar (for variables in closures), obj_routconst (for
+;; constants inside routines), obj_initdata (for data in the initialization routine)
+
+(defmethod output_ccode ((obj obj_var) str)
+  (error "output_ccode obj_var ~s" obj)
+)
+
+(defmethod put_destination ((obj obj_var) dest)
+  (build_obj_compute
+   dest
+   (list obj)
+   (cond ((obj_ptrvar-p obj) :value)
+	 ((obj_longvar-p obj) :long)
+	 (t (error "put_destination obj strangevar ~S dest ~S" obj dest)))
+   ))
+
+
+(defmethod output_ccode ((obj obj_compute) str)
+  (format str "/* obj_compute.#~d */~%" (obj_compute-compserial obj))
+  (let ( (dest (obj_compute-dest obj)) )
+   (cond ((null dest)
+	  (format str " (void) ("))
+	 ((obj_ptrvar-p dest) (format str "basilys_checked_assign(/*comput*/")))
+    (mapc (lambda (s) (cond 		;order matters here!
+		       ( (stringp s) (format str "~a" s) )
+		       ( (integerp s) (format str "~d" s) )
+		       ( (null s) (format str "/*coputenil*/NULL") )
+		       ( (symbolp s)
+			 (format str "(/*compute symb*/BASILYSG(~S))" s) )
+		       ( (or (obj_instr-p s) (obj_var-p s) (obj_data-p s)
+			     (obj_closedvar-p s) 
+			     (obj_routconst-p s) (obj_verbatim-p s)
+			     (obj_cstring-p s)
+			     )		;before the atom test!
+			 (output_ccode s str) )
+		       ( (atom s) 
+			 (format str "(/*compute son [~S]*/~s)" (type-of s) s) )
+		       ( t (error "output_ccode obj_compute ~s !!invalid son ~s" obj s))))
+	  (obj_compute-sons obj))
+    (cond  ((null dest)
+	    (format str ");~%"))
+	   ((obj_ptrvar-p dest) (format str ");~%"))
+	   ((obj_longvar-p dest) (format str ";~%"))
+	   )
+    ))
+
+
+(defmethod put_destination ((obj obj_compute) dest)
+  (let ( (otyp (obj_compute-otype obj)) 
+	 (destyp  (query_ctype dest))
+	 )
+    (cond  (  (eq ':void otyp)
+	      (let ( (nblo (make-obj_block :instrs (list obj (make-obj_verbatim :vstr "/*Void*/NULL")))) )
+		(put_destination nblo dest))
+	      )
+	   (
+	    (or (null otyp) (null destyp) (eq otyp destyp))
+	    (setf (obj_compute-sons obj) (append (list dest " = ") (obj_compute-sons obj)))
+	    (setf (obj_compute-dest obj) dest)
+	    nil)
+	   (t 
+	    (make-obj_block :instrs 
+			    (list 
+			     obj
+			     (make-obj_verbatiminstr :vstr (format nil "/*incompatible put_destination dest ~S otyp ~S*/" dest otyp))
+			     (build_obj_compute
+			      dest
+			      (case otyp 
+				(:long (list (make-obj_verbatim :vstr "/*incompatput:long*/0L")))
+				(:value (list (make-obj_verbatim :vstr "/*incompatput:value*/(void*)0")))
+				(otherwise (list (make-obj_verbatim :vstr (format nil "/*incompatput- ~S */0" otyp))))
+				)
+			      otyp
+			      )
+			     ))))))
+
+(defmethod get_destination ((obj obj_compute))
+   (obj_compute-dest obj)
+)
+
+(defstruct (obj_ptrvar (:include obj_var)))
+
+(defstruct (obj_longvar (:include obj_var)))
+
+(defmethod  print-object ((ov obj_ptrvar) st)
+  (if (cold_any_binding-p (obj_ptrvar-vbind ov))
+      (format st "ObjPtrVar@~d/~S?~S" 
+	      (obj_ptrvar-voffset ov) 
+	      (cold_any_binding-bname (obj_ptrvar-vbind ov))
+	      (obj_ptrvar-vwhy ov)
+	      )
+      (call-next-method ov st)
+))
+
+(defmethod  print-object ((ov obj_longvar) st)
+  (if (cold_any_binding-p (obj_longvar-vbind ov))
+      (format st "ObjLongVar@~d/~S?~S" 
+	      (obj_longvar-voffset ov) 
+	      (cold_any_binding-bname (obj_longvar-vbind ov))
+	      (obj_longvar-vwhy ov)
+	      )
+      (call-next-method ov st)
+      ))
+
+
+(defconstant cold_return_var
+  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_RETVAL_ :type :value) 
+		   :voffset 0))
+
+(defconstant cold_tempslot_var
+  (make-obj_ptrvar :vbind (make-cold_typed_binding :bname '_TMPSLOT_ :type :value) 
+		   :voffset 1))
+
+(defconstant cold_tempnum_var
+  (make-obj_longvar :vbind (make-cold_typed_binding :bname '_TMPNUM_ :type :long) 
+		   :voffset 0))
+
+
+(defmethod output_ccode ((obj obj_ptrvar) str)
+  (let ((b (obj_var-vbind obj))
+	(o (obj_var-voffset obj)))
+    (if b (format str "/*~S ? ~S*/" (cold_any_binding-bname b)
+		  (obj_var-vwhy obj)
+		  )
+      (format str "/*??~S*/" (obj_var-vwhy obj)))
+    (format str "curfram__.varptr[~d]" o)
+    )
+)
+
+(defmethod query_ctype ((obj obj_ptrvar))
+':value)
+
+
+
+(defmethod query_ctype ((obj obj_compute))
+  (obj_compute-otype obj))
+
+(defmethod output_ccode ((obj obj_longvar) str)
+  (let ((b (obj_var-vbind obj))
+	(o (obj_var-voffset obj)))
+    (if b (format str "/*~S ? ~S*/" 
+		  (cold_any_binding-bname b)
+		  (obj_var-vwhy obj)
+		  )
+      (format str "/*??~S*/" (obj_var-vwhy obj)))
+    (format str "curfram__.varnum[~d]" o)
+    )
+  )
+
+
+(defmethod output_ccode ((obj obj_closetq) str)
+  (let ((d (obj_closetq-cldest obj))
+	(s (obj_closetq-val obj)))
+    (or (obj_closedvar d) 
+	(error "not closedvar in obj_closetq ~S~%" obj))
+    (format str "/*closetq*/ {~% void* d = ")
+    (output_ccode d str)
+    (format str " = ")
+    (output_ccode s str)
+    (format str ";~%")
+    (format str "basilysgc_touch_dest(curfram__.clos, d); }~%")
+))
+
+(defmethod query_ctype ((obj obj_longvar))
+':long)
+
+(defmethod query_ctype ((obj integer))
+':long)
+
+(defstruct obj_closedvar
+  cvar					;the name of the closed variable
+  cfun					;the function of the closure
+  coffset				;the offset inside the closure
+)
+
+(defmethod put_destination ((obj obj_closedvar) dest)
+  (build_obj_compute
+   dest
+   (list obj)
+   :value
+   ))
+
+(defmethod output_ccode ((obj obj_closedvar) str)
+  (format str "/*clovar ~s*/ curfram__.clos->tabval[~d]" 
+	  (obj_closedvar-cvar obj) (obj_closedvar-coffset obj))
+)
+
+(defstruct obj_routconst
+  krout					;the routine quoting this constant
+  kval					;the value of the constant
+  koffset 				;the offset inside the function
+  kwhy					;string why
+)
+
+
+(defun newobjconst (val &optional why)
+  (let 
+      ( (curout (compilation-currout this_compilation) )
+	)
+    (assert (obj_data-p val) (val) "non-data values for newobjconst ~S" val)
+    (if (and (obj_routine-p curout) (not (obj_initroutine-p curout)))
+	;; usual case, we are in some routine
+	(let 
+	    ( (datarout (obj_routine-datarout curout)) )
+	  (or (obj_dataroutine-p datarout) 
+	      (error "newobjconst bad datarout ~S in curout ~S~%" datarout curout))
+	  (let ( (off (position val (obj_dataroutine-roudata datarout)))
+		 (ln (length (obj_dataroutine-roudata datarout))) )
+	    (if off 
+		(progn
+		  ;;(warn "newobjconst val=~S found off=~S ln=~S~%" val off ln)
+		  (make-obj_routconst :krout curout 
+				       :kval val 
+				       :koffset (- ln off 1)
+				       :kwhy why
+				       )
+		  )
+	      (let ( (ln (length (obj_dataroutine-roudata datarout))) )
+		(push val (obj_dataroutine-roudata datarout))
+		(let ( (newconst (make-obj_routconst :krout curout :kval val :koffset ln :kwhy why)) )
+		  newconst
+		  )
+		))))
+      ;; otherwise it is a global data 
+      (progn
+	(if  (null (currout_data2ptr val)) 
+	    (add_cdata val (concatenate 'string "newobjconst-" (string why)))
+	  val)
+	)
+      )))
+
+
+(defmethod output_ccode ((obj obj_routconst) str)
+  (let ((kval (obj_routconst-kval obj))
+	(kwhy (obj_routconst-kwhy obj))
+	)
+    (cond ( (symbolp kval)
+	    (format str "/*constsymb ~S ? ~S*/" kval kwhy) )
+	  ( (obj_data-p kval)
+	    (format str "/*const[~S] ~S ? ~S*/" 
+		    (type-of kval) (obj_data-comname kval) kwhy)
+	    )
+	  ( t
+	    (format str "/*const/ty[~S] ? ~S*/" (type-of kval) kwhy)))
+    (format str "curfram__.clos->rout->tabval[~d]"
+	    (obj_routconst-koffset obj))
+    ))
+
+
+(defstruct (obj_mkclosure (:include obj_instr))
+  dest 					;optional destination
+  cfun					;closure function
+  cvals					;closed values
+  kobjrout				;closure object routine constant
+)
+
+(defmethod put_destination ((obj obj_mkclosure) dest)
+  (setf (obj_mkclosure-dest obj) dest)
+  nil
+)
+
+(defmethod get_destination ((obj  obj_mkclosure))
+  (obj_mkclosure-dest obj)
+)
+
+(defmethod output_ccode ((obj obj_mkclosure) str)
+  (format str "{")
+  (format_c_comment str "**mkclosure ~S ~%**~%" obj)
+  (let ( ( cvals (obj_mkclosure-cvals obj))
+	 ( dest (obj_mkclosure-dest obj))
+	 ( cfun (obj_mkclosure-cfun obj))
+	 ( kobjrout (obj_mkclosure-kobjrout obj))
+	 )
+    (format str " struct BASILYS_CLOSURE_STRUCT(~d) *newclos_=0;~%"
+	    (my_length_gt_1 cvals))
+    (format str " newclos_ = basilysgc_allocate(sizeof(*newclos_),0);~%")
+    (format str " newclos_->discr = (void*)BASILYSG(DISCR_CLOSURE);~%")
+    (format str " newclos_->nbval = ~d;~%"  (length cvals))
+    (if dest
+	(progn (output_ccode dest str) (format str " = (void*)newclos_;~%")))
+    (format str " newclos_->rout = ")
+    (output_ccode kobjrout str)
+    (format str ";~%")
+    (loop
+      for crk from 0
+      for cva in cvals
+      do
+      (format str "newclos_->tabval[~d] = " crk)
+      (output_ccode cva str)		;
+      (format str ";~%")
+      )
+    )
+  (format str "}/**end mkclosure*/~%")
+;  (finish-output str)
+  )
+
+(defstruct (obj_block (:include obj_instr))
+  instrs)
+
+(defmethod output_ccode ((obj obj_block) str)
+  (let ((instrs (obj_block-instrs obj)))
+    (format str "{~%")
+    (mapc (lambda (i) 
+	    (if (obj_instr-p i) 
+		(progn 
+		  (output_ccode i str) (format str ";~%"))))
+	  instrs)
+    (format str "}~%")
+;    (finish-output str)
+))
+
+(defmethod query_ctype ((obj obj_block))
+  (let ((lastinstr (last (obj_block-instrs obj))))
+    (and lastinstr (query_ctype (first lastinstr))))
+)
+
+(defmethod put_destination ((obj obj_block) dest)
+  (let ((instrs (obj_block-instrs obj)))
+    (let ( (l (last instrs) ))
+      (if (consp l) 
+	  (let ( (nd (put_destination (first l) dest)) )
+	    (if nd (setf (first l) nd))
+	    )
+      ))
+    nil
+    ))
+
+(defmethod get_destination ((obj obj_block))
+  (let ((instrs (obj_block-instrs obj)))
+    (let ( (l (last instrs) ))
+      (if (consp l) (get_destination (first l))))))
+  
+
+(defstruct (obj_if (:include obj_instr))
+  ob_cond ob_then ob_else)
+
+(defmethod output_ccode ((obj obj_if) str)
+  (let ( (ocond (obj_if-ob_cond obj))
+	 (othen (obj_if-ob_then obj))
+	 (oelse (obj_if-ob_else obj)) )    
+    (format str "{ /*if*/~%")
+    (if (obj_instr-p ocond) (error "too complex (objinstr) cond in obj_if ~S" obj))
+    (format str " if (")
+    (output_ccode ocond str)
+    (format str ") {/*then*/~%")
+    (output_ccode othen str)
+    (if oelse 
+	(progn
+	  (format str "} else {~%")
+	  (output_ccode oelse str)
+	  (format str "}~%"))
+      (format str "}/*noelse*/;~%"))
+    (format str "} /*endif*/~%")
+))
+
+
+(defmethod query_ctype ((obj obj_if))
+  (let ( (ocond (obj_if-ob_cond obj))
+	 (othen (obj_if-ob_then obj))
+	 (oelse (obj_if-ob_else obj)) )    
+    (let ( (tythen (query_ctype othen)))
+      (if oelse
+	  (and (eq (query_ctype oelse) tythen) tythen)
+	tythen)
+)))
+
+
+
+(defmethod put_destination ((obj obj_if) dest)
+  (let ( (ocond (obj_if-ob_cond obj))
+	 (othen (obj_if-ob_then obj))
+	 (oelse (obj_if-ob_else obj)) )
+;    (and othen (get_destination othen) oelse (get_destination oelse)
+;	 (error "obj_if ~S already got destination in ~S" 
+;		obj (obj_routine-syname (compilation-currout this_compilation))))
+    (let ((dthen (put_destination othen dest))
+	  (delse (if oelse (put_destination oelse dest) 
+		   (build_obj_compute dest (list "NULL") (query_ctype othen)))))
+      (if dthen (setf (obj_if-ob_then obj) dthen))
+      (if delse (setf (obj_if-ob_else obj) delse))
+      )
+    nil
+))
+
+
+(defmethod get_destination  ((obj obj_if))
+  (let ( (ocond (obj_if-ob_cond obj))
+	 (othen (obj_if-ob_then obj))
+	 (oelse (obj_if-ob_else obj)) )
+    (if oelse
+	(and (eq (get_destination othen) (get_destination oelse))
+	     (get_destination othen))
+      (get_destination othen)
+    )))
+
+
+
+;;;;;;;;;;; calls & sends
+
+;;;; calls
+(defstruct (obj_call (:include obj_instr))
+  dest					;main destination
+  clos					;called closure
+  xtraresults				;other results
+  args					;arguments
+  )
+
+
+
+(defmethod output_ccode ((obj obj_call) str)
+  (let* ( (dest (obj_call-dest obj))
+	  (clos (obj_call-clos obj))
+	  (xresults (obj_call-xtraresults obj))
+	  (argseq (obj_call-args obj)) 
+	  (arg1 (and (consp argseq) (car argseq))) 
+	  (revargtypeseq nil)
+	  (revrestypeseq nil)
+	  (oargs (and (consp argseq) (cdr argseq)))
+	  )
+    (format str "/*-*call:*/~%{" obj)
+    (if xresults
+	(format str " union basilysparam_un restab[~d];~%" (length xresults)))
+    (if oargs
+	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
+    (if xresults
+	(format str " memset(restab, 0, sizeof(restab));~%"))
+    (if oargs
+	(format str " memset(argtab, 0, sizeof(argtab));~%"))
+    (loop for ark from 0 for arg in oargs do
+	  (case (query_ctype arg)
+		(:long (format str " argtab[~d].bp_long = " ark)
+		       (output_ccode arg str)
+		       (push "BPARSTR_LONG" revargtypeseq)
+		       (format str ";~%")
+		       )
+		((:value nil) 
+		 (if arg 
+		     (progn
+		       (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
+		       (output_ccode arg str)
+		       (push "BPARSTR_PTR" revargtypeseq)
+		       (format str ");~%"))
+		   (format str " argtab[~d].bp_aptr /*nil arg*/ = NULL;~%")))
+		(otherwise (error "output_ccode obj_callcannot handle arg ~s in ~s" arg obj)))
+	  )
+    (loop for resrk from 0 for xres in xresults do
+	  (case (query_ctype xres)
+		(:long (format str " restab[~d].bp_longptr = & (" resrk)
+		       (output_ccode xres str)
+		       (push "BPARSTR_LONG" revrestypeseq)
+		       (format str ");~%"))
+		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
+		 (output_ccode xres str)
+		 (push "BPARSTR_PTR" revrestypeseq)
+		 (format str ");~%"))
+		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
+	  )
+    (cond
+     ((obj_ptrvar-p dest) 
+      (format str "/*ptrappl*/ basilys_checked_assign(")
+      (output_ccode dest str)
+      (format str " = "))
+     ((null dest)
+      (format str "/*nodestappl*/ (void) "))
+     (dest
+      (assert (not (obj_longvar-p dest)))
+      (format str "/*noptrappl*/")
+      (output_ccode dest str)
+      (format str " = "))
+     )
+    (format str "basilysgc_apply(((void*)(")
+    (output_ccode clos str)
+    (format str ")), (")
+    (output_ccode arg1 str)
+    (format str "),~%   (")
+    (loop for argtype in (reverse revargtypeseq) do 
+	  (format str " ~a" argtype))
+    (format str " \"\"), ")
+    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
+    (format str ", ~%  (")
+    (loop for restype in (reverse revrestypeseq) do 
+	  (format str " ~a" restype))
+    (format str " \"\"), ")
+    (if xresults (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
+    (if
+	(obj_ptrvar-p dest)
+	(format str "));~%")
+      (format str ");~%"))
+    (format str "~%} /*endcall*/ ~%")
+;    (finish-output str)
+    )
+  )
+
+(defmethod put_destination ((obj obj_call) dest)
+  (setf (obj_call-dest obj) dest)
+  nil
+)
+
+(defmethod get_destination ((obj obj_call))
+  (obj_call-dest obj)
+)
+
+
+
+;;;; sends
+(defstruct (obj_send (:include obj_instr))
+  obs_dest					;main destination result
+  obs_sel					;selector
+  obs_xtraresults				;other results
+  obs_recv					;reciever
+  obs_args					;arguments
+  )
+
+(defmethod output_ccode ((obj obj_send) str)
+  (let ( (odest (obj_send-obs_dest obj))
+	 (osel (obj_send-obs_sel obj))
+	 (oxtrares (obj_send-obs_xtraresults obj))
+	 (orecv (obj_send-obs_recv obj))
+	 (oargs (obj_send-obs_args obj)) 
+	 (revargtypeseq nil)
+	 (revrestypeseq nil)
+	 )
+    (format str "/*-*send:*/~%{" obj)
+    (if oxtrares
+	(format str " union basilysparam_un restab[~d];~%" (length oxtrares)))
+    (if oargs
+	(format str " union basilysparam_un argtab[~d];~%" (length oargs)))
+    (if oxtrares
+	(format str " memset(restab, 0, sizeof(restab));~%"))
+    (if oargs
+	(format str " memset(argtab, 0, sizeof(argtab));~%"))
+    (loop for ark from 0 for arg in oargs do
+	  (case (query_ctype arg)
+		(:long (format str " argtab[~d].bp_long = " ark)
+		       (output_ccode arg str)
+		       (push "BPARSTR_LONG" revargtypeseq)
+		       (format str ";~%")
+		       )
+		((:value nil)  (format str " argtab[~d].bp_aptr = (basilys_ptr_t*) &(" ark)
+		 (output_ccode arg str)
+		 (push "BPARSTR_PTR" revargtypeseq)
+		 (format str ");~%"))
+		(otherwise (error "output_ccode obj_callcannot handle arg ~s in ~s" arg obj)))
+	  )
+    (loop for resrk from 0 for xres in oxtrares do
+	  (case (query_ctype xres)
+		(:long (format str " restab[~d].bp_longptr = & (" resrk)
+		       (output_ccode xres str)
+		       (push "BPARSTR_LONG" revrestypeseq)
+		       (format str ");~%"))
+		((:value nil)  (format str " restab[~d].bp_aptr = (basilys_ptr_t*) &(" resrk)
+		 (output_ccode xres str)
+		 (push "BPARSTR_PTR" revrestypeseq)
+		 (format str ");~%"))
+		(otherwise (error "output_ccode obj_call cannot handle res ~s in ~s" xres obj)))
+	  )
+    (if odest
+	(progn 
+	  (output_ccode odest str)
+	  (format str " = "))
+      (format str "(void) "))
+    (format str "basilysgc_send(((void*)(")
+    (output_ccode orecv str)
+    (format str ")), (")
+    (output_ccode osel str)
+    (format str "),~%   (")
+    (loop for argtype in (reverse revargtypeseq) do 
+	  (format str " ~a" argtype))
+    (format str " \"\"), ")
+    (if oargs (format str "argtab") (format str "/*no args*/ (union basilysparam_un*)0"))
+    (format str ", ~%  (")
+    (loop for restype in (reverse revrestypeseq) do 
+	  (format str " ~a" restype))
+    (format str " \"\"), ")
+    (if oxtrares (format str "restab") (format str "/*no res*/ (union basilysparam_un*)0"))
+    (format str ");~%")
+    (format str "~%} /*endsend*/ ~%")
+;    (finish-output str)
+    ))
+
+
+(defmethod put_destination ((obj obj_send) dest)
+  (setf (obj_send-obs_dest obj) dest)
+  nil
+)
+
+(defmethod get_destination ((obj obj_send))
+  (obj_send-obs_dest obj)
+)
+
+;;;;;;;;;;; forever instruction
+
+(defstruct (obj_forever (:include obj_instr))
+  obforever_bind					;forever binding
+  obforever_res					;result
+  obforever_dest					;forever destination
+  obforever_body					;body
+  obforever_epilogue			;epilogue
+  )
+
+(defmethod put_destination ((obj obj_forever) dest)
+  (setf (obj_forever-obforever_dest obj) dest)
+  nil
+)
+
+(defmethod get_destination ((obj obj_forever))
+  (obj_forever-obforever_dest obj)
+)
+
+
+(defmethod output_ccode ((obj obj_forever) str)
+  (let* ( (lbind (obj_forever-obforever_bind obj))
+	  (lres  (obj_forever-obforever_res obj))
+	  (ldest (obj_forever-obforever_dest obj))
+	  (lepil (obj_forever-obforever_epilogue obj))
+	  (lbody (obj_forever-obforever_body obj)) 
+	  (luniq (cold_forever_binding-uniq lbind))
+	  )
+    (format str "/*forever ~S*/{~%" luniq)
+    (output_ccode lres str)
+    (format str " = 0;~%")
+    (format str " lab_startforever_~a:;~%" (string luniq))
+    (loop for rk from 1 for ins in lbody do
+	  (format str "/*forever ~S instr#~d*/" luniq rk)
+	  (output_ccode ins str)
+	  (format str ";~%"))
+    (format str "/*againforever*/ goto lab_startforever_~a;~%" (string luniq))
+    (format str " lab_endforever_~a:;~%" (string luniq))
+    (if ldest 
+	(progn
+	  (format str "/*foreverdest ~S*/~%" luniq)
+	  (output_ccode ldest str)
+	  (format str " = ")
+	  (output_ccode lres str)
+	  (format str ";~%")
+	  ))
+    (if lepil
+	(progn
+	  (format str "/*foreverdest ~S*/~%" lepil)
+	  (output_ccode lepil str)
+	  (format str ";~%")
+	  ))
+    (format str "/*endforever ~S*/}~%" luniq)
+;    (finish-output str)
+    ))
+		
+;;;;
+
+(defstruct (obj_exit (:include obj_instr))
+  obxit_bind 
+  obxit_body
+)
+
+(defmethod put_destination ((obj obj_exit) dest)
+  nil
+)
+
+(defmethod output_ccode ((obj obj_exit) str)
+  (let ( (xuniq (cold_forever_binding-uniq (obj_exit-obxit_bind obj))) )
+    (format str "{ /*Exit ~S*/~%" xuniq)
+    (loop for irk from 1
+	  for ins in (obj_exit-obxit_body obj)
+	  do
+	  (format str "/*exiting ~S ins#~d*/~%" xuniq irk)
+	  (output_ccode ins str)
+	  (format str ";~%"))
+    (format str " /*exitjump*/ goto lab_endforever_~a;~%" (string xuniq))
+    (format str "} /*end Exit ~S*/~%" xuniq)
+))
+
+;;;;;;;;;;; return instruction
+(defstruct (obj_return (:include obj_instr))
+  mainreturn				;the main returned value
+  extrareturns				;the sequence of extra returned values
+)
+
+(defmethod put_destination ((obj obj_return) dest)
+  (let ((nmd (put_destination (obj_return-mainreturn obj) dest))) 
+    (if nmd (setf (obj_return-mainreturn obj) nmd))
+    ))
+
+
+(defmethod output_ccode ((obj obj_return) str)
+  (format str "/*-*Returning**/ {~%")
+  (format_c_comment str "objreturn ~s" obj)
+  (let ( 
+	(mainret (obj_return-mainreturn obj))
+	(xtrarets (obj_return-extrareturns obj))
+	)
+    (if (null mainret) 
+	(format str "/*no retval*/ curfram__.varptr[0] = (void*)0 ")
+      (let ( (maindest (get_destination mainret)) )
+	(format_c_comment str "mainret ~S maindest ~S" mainret maindest)
+	(if (not (eq maindest cold_return_var))
+	    (format str "/*simple retval*/ curfram__.varptr[0] = ")
+	  (format str "/*got retval*/ "))
+	(output_ccode mainret str)
+	))
+    (format str ";~%")
+    (if xtrarets 
+	(format str " if (!xrestab_ || !xresdescr_) goto lab_endrout;~%"))
+    (loop
+     for ark from 0
+     for ret in xtrarets 
+     do
+     (format_c_comment str "*!* extra result #~d = ~s *~%" ark ret)
+     (let ( (rettype (query_ctype ret)) )
+       (case rettype
+	     (:long 
+	      (format str " if (xresdescr_[~d] != BPAR_LONG) goto lab_endrout;~%" ark)
+	      (format str " if (xrestab_[~d].bp_longptr)~%     *(xrestab_[~d].bp_longptr) = (" ark ark)
+	      (output_ccode ret str)
+	      (format str ");~%")
+	      )
+	     ((:value nil) 
+	      (format str " if (xresdescr_[~d] != BPAR_PTR) goto lab_endrout;~%" ark)
+	      (format str " if (xrestab_[~d].bp_rptr)~%     *(xrestab_[~d].bp_rptr) = (void*) (" ark ark)
+	      (output_ccode ret str)
+	      (format str ");~%")
+	      )
+	     (otherwise (error "bad return type ~s in ~s" rettype obj))
+	     )
+       )))
+  (format str " goto lab_endrout;~%")
+  (format str "} /*end return*/~%")
+;  (finish-output str)
+  )
+
+
+(defstruct (obj_routine (:include obj_instr))
+  pfun					;prog function
+  syname				;symbol for easier naming it (or nil)
+  rank					;integer rank of this function
+  obody					;sequence of C instr
+  nbptr					;total number of pointer variables
+  nbnum					;total number of long variables
+  nbdouble				;total number of double variables
+  freevptrs				;list of free varptr to be reused
+  freevnums				;list of free varlong to be reused
+  freevdbls				;list of free vardbl to be reused
+  dataclos				;the associated dataclosure
+  datarout				;the associated dataroutine
+  data2ptrhash				;hash associating data to pointers
+)
+
+(defmethod  print-object ((ob obj_routine) st)
+  (format st "ObjRoutine{SyName=~S Obody=~S DataClos=~S DataRout=~S}" 
+	  (obj_routine-syname ob)
+	  (obj_routine-obody ob)
+	  (obj_routine-dataclos ob)
+	  (obj_routine-datarout ob)
+	  ))
+
+
+(defun routine_link_data2ptr (orout odata ptr)
+  (assert (obj_routine-p orout))
+  (assert (obj_data-p odata))
+  (assert ptr)
+  (setf (gethash odata (obj_routine-data2ptrhash orout)) ptr)
+)
+
+(defun routine_get_ptr4data (orout odata)
+  (assert (obj_routine-p orout))
+  (assert (obj_data-p odata)) 
+  (gethash odata (obj_routine-data2ptrhash orout))
+)
+
+(defun currout_data2ptr (odata)
+  (assert (obj_data-p odata))
+  (let ( (currout
+	  (or (compilation-currout this_compilation)
+	      (compilation-initrout this_compilation))) )
+    (assert (obj_routine-p currout))
+    (routine_get_ptr4data currout odata)
+))
+
+(defun currout_link_data2ptr (odata ptr)
+  (assert (obj_data-p odata))
+  (let ( (currout
+	  (or (compilation-currout this_compilation)
+	      (compilation-initrout this_compilation))) )
+    (assert (obj_routine-p currout)) 
+    (routine_link_data2ptr currout odata ptr)
+))
+
+(defun routinecname (rou) 
+  (if (obj_routine-p rou)
+      (let ( (rk (obj_routine-rank rou))
+	     (sn (obj_routine-syname rou)) )
+	(if (symbolp sn)
+	    (let ( (tsn (map 'string (lambda (c) (if (alphanumericp c) c #\_)) (symbol-name sn))) )
+	      (format nil "rout__~d__~a" rk tsn))
+	  (format nil "rout__~d" rk)))))
+
+(defmethod output_ccode ((obj obj_routine) str)
+  (let ( (rk (obj_routine-rank obj)) 
+	 (nbptr (obj_routine-nbptr obj))
+	 (nbnum (obj_routine-nbnum obj))
+	 (nbdouble (obj_routine-nbdouble obj))
+	 (oldcurout (compilation-currout this_compilation))
+	 )
+    (setf (compilation-currout this_compilation) obj)
+    (format str "~%~% /*** C routine ~d <~S> **/~%" rk (obj_routine-syname obj))
+    ;; (format_c_comment str "** routine ~S ~& routine rank ~d  **~%" obj rk)
+    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
+    (format str "     	     basilys_ptr_t firstargp_,~%")
+    (format str "	    	     const char xargdescr_[],~%")
+    (format str "              union basilysparam_un* xargtab_,~%")
+    (format str "              const char xresdescr_[],~%")
+    (format str "              union basilysparam_un* xrestab_)~%{")
+    (format str "#if ENABLE_CHECKING~%")
+    (format str "  static long thiscallcounter__;~%")
+    (format str "  long callcount_ = ++thiscallcounter__;~%")
+    (format str "#define callcount callcount_~%")
+    (format str "#else~%")
+    (format str "#define callcount 0L~%")
+    (format str "#endif~%")
+    (format str "  struct {~%")
+    (format str "    unsigned nbvar;~%")
+    (format str "    struct basilysclosure_st* clos;~%")
+    (format str "    struct excepth_basilys_st* exh;~%")
+    (format str "    struct callframe_basilys_st* prev;~%")
+    (format str "    void* varptr[~d];" (+ nbptr 1))
+    (format str "    long varnum[~d];" (+ nbnum 1))
+    (format str "    double vardbl[~d];" (+ nbdouble 1))
+    (format str "    long _spare_;")
+    (format str "  } curfram__ = { /*nbvar*/~d,~%" nbptr)
+    (format str "   (struct basilysclosure_st*)0,~%")
+    (format str "   (struct excepth_basilys_st*)0,~%")
+    (format str "   (struct callframe_basilys_st*)0, ~%")
+    (progn 
+      (format str "/*~d ptrvars:*/ {" nbptr)
+      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
+      (format str "}, ~%")
+      ) 
+    (progn 
+      (format str "/*~d numvars:*/ {" nbnum)
+      (loop for ix from 1 to nbnum do (format str " 0L,"))
+      (format str " 0L }, ~%")
+      )
+    (progn 
+      (format str "/*~d doublevars:*/ {" nbdouble)
+      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
+      (format str " 0.0 }, ~%")
+      )
+    (format str " 0L };~% curfram__.prev = (void*)basilys_topframe;~%")
+    (format str " curfram__.clos = closp_;~%")
+    (format str " basilys_topframe= (void*)(&curfram__);~%")
+    (format str "/* body ~d start */~%" rk)
+    (format str "basilys_check_call_frames(BASILYS_ANYWHERE, \"start ~a\");~%" (routinecname obj))
+    (output_ccode (obj_routine-obody obj) str)
+    (format str "/* body ~d end */~%" rk)
+    (format str " lab_endrout:~%") 
+    (format str "basilys_check_call_frames(BASILYS_ANYWHERE, \"end ~a\");~%" (routinecname obj))
+    (format str " basilys_topframe= (void*)(curfram__.prev); return curfram__.varptr[0];")
+    (format str "#undef callcount~%")
+    (format str "} /* end rout_~d */~%~%" rk)
+    (setf (compilation-currout this_compilation) oldcurout)
+    (finish-output str)
+    ))
+
+
+
+(defmethod output_cdecl ((obj obj_routine) str)
+  (let ((rk (obj_routine-rank obj)))
+    (format str "~%/** declroutine routine rank ~d  **/~%" 
+	    rk)
+    (format str "static basilys_ptr_t ~a (basilysclosure_ptr_t closp_,~&" (routinecname obj))
+    (format str "     	     basilys_ptr_t firstargp_,~%")
+    (format str "	    	     const char xargdescr_[],~%")
+    (format str "              union basilysparam_un* xargtab_,~%")
+    (format str "              const char xresdescr_[],~%")
+    (format str "              union basilysparam_un* xrestab_);~%")
+    ))
+
+
+;; make a pointer variable inside a routine, using the free list if possible
+;; orout is the object routine inside which it is used
+;; bind is the binding
+;; why is some explanation string
+(defun newobjptrvar (orout bind why)
+  (assert (obj_routine-p orout))
+  (assert (cold_any_binding-p bind))
+  (if why (assert (stringp why)))
+  (if (consp (obj_routine-freevptrs orout))
+      (let ( (fvar (pop (obj_routine-freevptrs orout))) )
+	(assert (obj_ptrvar-p fvar))
+	(assert (obj_var-vfree fvar))
+	(assert (eq (obj_var-vrout fvar) orout))
+	;; don't reuse fvar for ease of debugging but make a new var of same offset
+	(let ( (rvar (copy-obj_ptrvar fvar)) )
+	  (setf (obj_var-vbind rvar) bind)
+	  (setf (obj_var-vwhy rvar) why)
+	  (setf (obj_var-vfree fvar) rvar)
+	  (setf (obj_var-vfree rvar) nil)
+	  rvar
+	))
+    (let ( (nvar (make-obj_ptrvar :vbind bind 
+				  :voffset (incf (obj_routine-nbptr orout))
+				  :vwhy why
+				  :vrout orout)) )
+      nvar
+      )))
+
+;; free a pointer variable to enable its reuse
+(defun freeobjptrvar (ovar)
+  (assert (obj_ptrvar-p ovar))
+  (assert (cold_any_binding-p (obj_var-vbind ovar)))
+  (let ( (orout (obj_var-vrout ovar)) 
+	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
+	 )
+    (assert (obj_routine-p orout))
+    (push ovar (obj_routine-freevptrs orout))
+    (setf (obj_var-vfree ovar) t)
+    nil
+))
+
+
+;; make a long variable inside a routine, using the free list if possible
+;; orout is the object routine inside which it is used
+;; bind is the binding
+;; why is some explanation string
+(defun newobjlongvar (orout bind why)
+  (assert (obj_routine-p orout))
+  (assert (cold_any_binding-p bind))
+  (if why (assert (stringp why)))
+  (if (consp (obj_routine-freevnums orout))
+      (let ( (fvar (pop (obj_routine-freevnums orout))) )
+	(assert (obj_longvar-p fvar))
+	(assert (obj_var-vfree fvar))
+	(assert (eq (obj_var-vrout fvar) orout))
+	;; don't reuse fvar for ease of debugging but make a new var of same offset
+	(let ( (rvar (copy-obj_longvar fvar)) )
+	  (setf (obj_var-vbind rvar) bind)
+	  (setf (obj_var-vwhy rvar) why)
+	  (setf (obj_var-vfree fvar) rvar)
+	  (setf (obj_var-vfree rvar) nil)
+	  rvar
+	))
+    (let ( (nvar (make-obj_longvar :vbind bind 
+				  :voffset (incf (obj_routine-nbnum orout))
+				  :vwhy why
+				  :vrout orout)) )
+      nvar
+      )))
+
+;; free a long variable to enable its reuse
+(defun freeobjlongvar (ovar)
+  (assert (obj_longvar-p ovar))
+  (assert (cold_any_binding-p (obj_var-vbind ovar)))
+  (let ( (orout (obj_var-vrout ovar)) 
+	 (oname (cold_any_binding-bname (obj_var-vbind ovar)))
+	 )
+    (assert (obj_routine-p orout))
+    (push ovar (obj_routine-freevnums orout))
+    (setf (obj_var-vfree ovar) t)
+    nil
+))
+
+
+(defgeneric compile_obj (cod env)
+  (:documentation "compilation of (any) Basilys code")
+)
+
+(defmethod compile_obj ((cod t) env)
+  (break "compile_obj t cod ~S~%! env ~S~%!  ~% <<<compilobj t" 
+	  cod env)
+  cod
+)
+
+(defmethod compile_obj ((cod cons) env)
+  (error "compile_obj consp cod ~S~%! env ~S~%!  ~% <<<compilobj cons" 
+	  cod env)
+  cod
+)
+
+(defmethod compile_obj ((cod integer) env)
+  cod
+)
+
+(defmethod compile_obj ((cod string) env)
+  cod
+)
+
+(defmethod compile_obj ((cod prog_cstring) env)
+  (make-obj_cstring :obcstr (prog_cstring-c_str cod))
+)
+
+;; the sole init routine has to be a subclass of objoutine to handle
+;; appropriately objpointers
+(defstruct (obj_initroutine (:include obj_routine))
+  inirou_datarankdict			;dictionnary mapping data to its rank
+)
+
+;; given a data, returns its integer rank in the initial routine or else nil
+(defun initrout_rank (obda)
+  (let ( (hrk 
+	  (gethash obda 
+		  (obj_initroutine-inirou_datarankdict
+		   (compilation-initrout this_compilation)))) )
+    ; to ease readability of the initrout we try to match the rank
+    ; with the varptr index into which it is usually stored
+    (if (integerp hrk) (+ hrk 2))
+))
+
+(defmethod output_cdecl ((obj obj_initroutine) str)
+  (format str  "~%~%/*-* declinitroutine  *-*/~%")
+  (format str "void* start_module_basilys(void*modata_);~%")
+)
+
+
+(defmethod output_ccode ((obj obj_initroutine) str)
+  (let ( (nbptr (obj_routine-nbptr obj))
+	 (nbnum (obj_routine-nbnum obj))
+	 (nbdouble (obj_routine-nbdouble obj))
+	 (cdata (reverse (compilation-cdata this_compilation)))
+	 (oldcurout (compilation-currout this_compilation))
+	 )
+    (setf (compilation-currout this_compilation) obj)
+    ;; (format str "~%~%/*-* initroutine~% ~S  **/~%" obj)
+    (format str "~%~%~%~%~%~%/*######### ccode initroutine ############*/~%")
+    (format str "void* start_module_basilys(void*modata_) {~%")
+    (format str "/*-*cdatalen ~d **/~%" (length cdata))
+    (format str " typedef struct cdata_st {~%")
+    (loop for rk from 0 for da in cdata do
+	  (format str "/*cdata ~d*/~%" rk)
+					;(format_c_comment str "**cdata #~d = ~s~%" rk da)
+	  (output_cdecl da str)
+	  )
+    (format str " long _extragap[2];} cdata_t;~%") 
+    (format str " cdata_t*cdat=0;~%")
+    (format str "  struct {~%")
+    (format str "    unsigned nbvar;~%")
+    (format str "    struct basilysclosure_st* clos;~%")
+    (format str "    struct excepth_basilys_st* exh;~%")
+    (format str "    struct callframe_basilys_st* prev;~%")
+    (format str "   void* varptr[~d];~%" (+ nbptr 1))
+    (format str "    long varnum[~d];~%" (+ nbnum 1))
+    (format str "    double vardbl[~d];~%" (+ nbdouble 1))
+    (format str "    long _extra_;~%" )
+    (format str "  } curfram__ = { /*nbvar*/~d,~%" nbptr)
+    (format str "   (struct basilysclosure_st*)0,~%")
+    (format str "   (struct excepth_basilys_st*)0,~%")
+    (format str "   (struct callframe_basilys_st*)0, ~%")
+    (progn 
+      (format str "/*~d ptrvars:*/ {" nbptr)
+      (loop for ix from 1 to nbptr do (format str " (void*)0,"))
+      (format str "}, ~%")
+      )
+    (if (> nbnum 0) (progn 
+      (format str "/*~d numvars:*/ {" nbnum)
+      (loop for ix from 1 to nbnum do (format str " 0L,"))
+      (format str "}, ~%")
+      ))
+    (if (> nbdouble 0) (progn 
+      (format str "/*~d doublevars:*/ {" nbdouble)
+      (loop for ix from 1 to nbdouble do (format str " 0.0,"))
+      (format str "}, ~%")
+      ))
+    (format str " 0L};~% curfram__.prev = basilys_topframe;~%")
+    (format str " basilys_topframe= (void*)(&curfram__);~%")
+    (format str "/*allocating and assigning cdata*/ {~%;~%")
+    (format str " debugeprintf(\"generated cdatlen ~d : size %d bytes\", (int)sizeof(cdata_t));~%" 
+	    (length cdata))
+    (format str " cdat = basilysgc_allocate(sizeof(cdata_t),0);~%")
+    (format str " debugeprintf(\" cdat %p - %p\", (void*)cdat, (void*)((char*)cdat + sizeof(cdata_t)));~%")
+    (loop for rk from 0 for da in cdata do
+	  (format str "~%/* assign cdata #~d*/~%" rk)
+	  (output_cassign da str)	
+	  )
+    (format str "/***** initcdata ***/~%")
+    (loop for rk from 0 for da in cdata do
+	  (format str "~%/* init cdata #~d*/~%" rk)
+	  (output_cinit da str)	
+	  (format str "~%/* endinit cdata #~d*/~%" rk)
+	  )
+    (format *error-output* ";;wrote ~d init cdata ~g cpusec~%" (length cdata) (cpusec))
+    (finish-output str)
+    (format str "} /*allocated, assigned, inited cdata*/~%")
+    (format str "/*filling cdata ****/~%")
+    (loop for rk from 0 for da in cdata do
+	  (format str "~%/* fill cdata #~d*/~%" rk)
+	  (output_cfill da str)	
+	  )
+    (finish-output str)
+    (format *error-output* ";;wrote ~d fill cdata ~g cpusec~%" (length cdata) (cpusec))
+    (format str "/*verifying cdata ****/~%")
+    (loop for rk from 0 for da in cdata do
+	  (format str "~%/* verify cdata #~d*/~%" rk)
+	  (output_cverify da str)	
+	  )
+    (format str "/*body of initrout*/~%")
+    (format *error-output* ";;before writing init body ~g cpusec~%" (cpusec))
+    (format str " debugeprintf(\"before init routine body\");~%")
+    (if (obj_routine-obody obj)  (output_ccode (obj_routine-obody obj) str))
+    (format str "; /* initrout body end */~%")
+    (let ( (nbsym (hash-table-count(compilation-symboldict this_compilation))) )
+      (format str "/*intern ~d symbols*/~%" nbsym)
+      (format *error-output* ";;writing init ~d interning ~g cpusec~%" nbsym (cpusec))
+      )
+    (let ( (symlist nil) ) 
+      (maphash (lambda (sym data) (push sym symlist)) 
+	       (compilation-symboldict this_compilation))
+      (let ( (sortedsymlist (sort symlist (lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2))))) )
+	(mapc (lambda (sym)
+		(let ( (sydata (gethash sym (compilation-symboldict this_compilation))) )
+					; (format_c_comment str "symbol ~S data ~S~%" sym sydata)
+		  (format str "/*interning ~S*/~%" sym)
+		  (if (keywordp sym)
+		      (format str "(void) basilysgc_intern_keyword(")
+		    (format str "(void) basilysgc_intern_symbol("))
+		  (output_ccode sydata str)
+		  (format str ");~%")
+		  ))
+	      sortedsymlist)))
+    (format str " goto lab_endrout;~%")
+    (format str " lab_endrout:~% debugeprintf(\"end init routine returning %p\", curfram__.varptr[0]);~%")
+    (format str " basilys_topframe= (void*)(curfram__.prev); return curfram__.varptr[0];")
+    (format str "}/* end start_module_basilys */~%")
+    (setf (compilation-currout this_compilation) oldcurout)
+    (finish-output str)
+    ))
+
+;;; compilation of nil
+(defmethod compile_obj ((cod null) env)
+  (make-obj_verbatim :vstr "/*Nil*/NULL")
+)
+
+
+;; compilation of symbols
+(defmethod compile_obj ((cod symbol) env)
+  (let ((bnd (cold_find_binding cod env)))
+    (or bnd (error "compile_obj symbol: unbound symbol ~s in env ~s~% <::compile_obj unboundsym ~S in ~S>" 
+		   cod env cod (obj_routine-syname (compilation-currout this_compilation))))
+    (cond ( (cold_value_binding-p bnd)
+	    (let ( (sdata (cold_value_binding-val bnd)) )
+	      (cond
+	       ( (eq (cold_value_binding-type bnd) :void)
+		 (make-obj_verbatim :vstr (format nil "/*Void ~S*/NULL" cod)))
+	       ( (obj_var-p sdata) sdata)
+	       ( (currout_data2ptr sdata) )
+	       ( t (newobjconst sdata "symb val"))
+	       )))
+	  ( (cold_class_binding-p bnd)
+	    ;; a class is a constant, to be put in the routine's constant data
+	    (let ( (cladata  (cold_class_binding-classdata bnd)) )
+	      (assert (obj_data-p cladata) () "compilobj: bad data ~S for class ~S bnd ~S" cladata cod bnd)
+	      (or (currout_data2ptr cladata) (newobjconst cladata "symb class"))
+	      ))
+	  ( (cold_field_binding-p bnd)
+	    (let ( (fldata (cold_field_binding-fieldata bnd)) )
+	      (assert (obj_data-p fldata) ()  "compilobj: bad data ~S for field ~S bnd ~S" fldata cod bnd)
+	      (or (currout_data2ptr fldata) (newobjconst fldata "symb field"))
+	      ))
+	  ( (cold_instance_binding-p bnd)
+	    (let ( (insdata (cold_instance_binding-instancedata bnd)) )
+	      (assert (obj_data-p insdata) ()  "compilobj: bad data ~S for instance ~S bnd ~S" insdata cod bnd)
+	      (or (currout_data2ptr insdata) (newobjconst insdata "symb inst"))
+	      ))
+	  ( (cold_selector_binding-p bnd)
+	    (let ( (seldata (cold_selector_binding-selectordata bnd)) )
+	      (assert (obj_data-p seldata) ()  "compilobj: bad data ~S for selector ~S bnd ~S" seldata cod bnd)
+	      (or (currout_data2ptr seldata) (newobjconst seldata "symb sel"))
+	      ))
+	  ( (cold_function_binding-p bnd)
+	    (let ( (fundata (cold_function_binding-fclodata bnd)) )
+	      (assert (obj_data-p fundata) ()  "compilobj: bad data ~S for function ~S bnd ~S" fundata cod bnd)
+	      (or (currout_data2ptr fundata) (newobjconst fundata "symb fun"))
+	      ))
+	  ( (cold_code_binding-p bnd) 
+	    (compile_obj (cold_code_binding-code bnd) env) )
+	  (t (error "unexpected compile_obj symbol ~s~%!! bnd ~s~%!!env ~s~% <::compile_obj unexpectedsym ~S {bnd ~S} in ~S>" 
+		    cod bnd env cod (type-of bnd)
+		    (obj_routine-syname (compilation-currout this_compilation)))))
+    ))
+
+
+;;; compilation of quoted symbols
+(defmethod compile_obj ((cod prog_quotesym) env)
+  (declare (ignore env))
+  (let ( (qs (prog_quotesym-qsym cod)) )
+    (cond ( (or (symbolp qs) (keywordp qs))
+;	    (warn "compilobj-quotesym cod=~S~%" cod)
+	    (let* ( (odatsym (get_obj_symbol qs "quotesym"))
+		    (osymptr  (currout_data2ptr odatsym))
+		    )
+;	    (warn "compilobj-quotesym odatsym ~S osymptr ~S~%" odatsym osymptr)
+	      (or osymptr (newobjconst odatsym "quotsym"))))
+	  ( t (error "compile_obj bad prog_quotesym ~S" cod) )
+    )
+))
+
+;; compilation of closed variable occurrences
+(defmethod compile_obj ((cod prog_closedvar) env)
+  (let ( (cfun (prog_closedvar-clv_fun cod))
+	 (cvar (prog_closedvar-clv_var cod)) )
+    (let* ( (clovarseq 
+	     (cond
+	      ( (prog_defun-p cfun) (prog_defun-fun_closvars cfun) )
+	      ( (prog_lambda-p cfun) (prog_lambda-lambda_closvars cfun) )
+	      ( t (cerror "compile_obj prog_closedvar bad cfun ~s for cod ~s" cfun cod))))
+	    (coff 
+	     (progn
+	       (position cvar clovarseq
+		:test (lambda (c1 cv2) 
+			(eq (if (symbolp c1) c1 (prog_closedvar-clv_var c1))
+			    (prog_closedvar-clv_var cv2)))))
+	     )
+	    )
+      (or coff (error "compile_obj prog_closedvar no offset for cod ~s ~%... in clovarseq ~S~%" 
+		      cod))
+      (make-obj_closedvar :cvar cvar :cfun cfun :coffset coff)
+      )))
+
+
+;; handling of closed variables in functions' closed variables and constants
+(defun handleclosvar (pcv env)
+  (if (and (prog_closedvar-p pcv)
+	   (prog_defun-p (prog_closedvar-clv_fun pcv)))
+      (let (
+	    (cva (prog_closedvar-clv_var pcv))
+	    )
+	(or (symbolp cva) (error "bad cva in handleclosvar pcv ~S" pcv))
+	(let ( (vbi (cold_find_binding cva env)) )
+	  (cond ( (cold_value_binding-p vbi)
+		 (cold_value_binding-val vbi) )
+		( (cold_class_binding-p vbi)
+		 (cold_class_binding-classdata vbi) )
+		( (cold_field_binding-p vbi)
+		 (cold_field_binding-fieldata vbi) )
+		( (cold_instance_binding-p vbi)
+		 (cold_instance_binding-instancedata vbi) )
+		( (cold_selector_binding-p vbi)
+		 (cold_selector_binding-selectordata vbi) )
+		( (cold_function_binding-p vbi)
+		 (cold_function_binding-fclodata vbi) )
+		( t 
+		 (error "handleclosdata unexpected binding vbi=~S cva=~S" 
+			vbi cva))
+		)
+	  ))
+      (progn
+	pcv)
+      )
+  )
+
+;;;; compilation of progns
+(defmethod compile_obj ((cod prog_progn) env)
+  (let ( (pbody (prog_progn-progn_body cod)) )
+    (make-obj_block :instrs
+		    (mapcar (lambda (comp) (compile_obj comp env)) pbody))
+))
+
+
+;;;; compilation of forevers
+
+(defmethod compile_obj ((cod prog_forever) env)
+  (let* ( (lbind (prog_forever-forever_bind cod))
+	  (lbody (prog_forever-forever_body cod)) 
+	  (lbnam (cold_any_binding-bname lbind))
+	  (luniq (cold_forever_binding-uniq lbind))
+	  (ltype (cold_forever_binding-type lbind))
+	  (epilo nil)
+	  (obody nil)
+	  (lvar nil)
+	  (nbind (make-cold_obforever_binding 
+		  :bname lbnam
+		  :type ltype
+		  :uniq luniq
+		  :lobvar nil))
+	  (newenv (cold_fresh_env env))
+	  )
+    (cold_put_binding nbind newenv)
+    (case ltype
+	  ( :value 
+	    (let ( (vvar 
+		    (newobjptrvar (compilation-currout this_compilation) lbind
+			       "forever value")) )
+	      (setf (cold_obforever_binding-lobvar nbind) vvar)
+	      (setq epilo (make-obj_clearptr :clrptrvar vvar))
+	      (setq lvar vvar)
+	      ))
+	  ( :long 
+	    (let ( (vvar 
+		    (newobjlongvar (compilation-currout this_compilation) lbind
+			       "forever num"
+			       )) )
+	      (setf (cold_obforever_binding-lobvar nbind) vvar)
+	      (setq epilo (make-obj_clearlong :clrlongvar vvar))
+	      (setq lvar vvar)
+	      ))
+	  (otherwise (error "bad forever ltype ~S in ~S" ltype cod))
+	  )
+    (setq obody (mapcar (lambda (i) (compile_obj i newenv)) lbody))
+    (if lvar (case ltype
+	       (:value (freeobjptrvar lvar))
+	       (:long (freeobjlongvar lvar))
+	       ))
+    (make-obj_forever 
+     :obforever_bind nbind
+     :obforever_res (cold_obforever_binding-lobvar nbind)
+     :obforever_dest nil
+     :obforever_body obody
+     :obforever_epilogue epilo
+     )
+    ))
+
+
+;;;;
+(defmethod compile_obj ((cod prog_exit) env)
+  (let* ( (ebind (prog_exit-exit_bind cod))
+	  (ebody (prog_exit-exit_body cod))
+	  (lvar (cold_any_binding-bname ebind))
+	  (nbind (cold_find_binding lvar env))
+	  (nbody (mapcar (lambda (i) (compile_obj i env)) ebody))
+	  (lasti (last nbody))
+	  )
+    (or (cold_obforever_binding-p nbind) 
+	(error "bad binding in compile_obj prog_exit ~S" cod))
+    (if (consp lasti) 
+	(let* ( (nobv (cold_obforever_binding-lobvar nbind))
+		(li (first lasti)) 
+		(nli (put_destination li nobv)) )
+	  (if nli 
+	      (setf (car lasti) 
+		    nli))))
+    (make-obj_exit
+     :obxit_bind nbind
+     :obxit_body nbody)
+    ))
+
+;;;; compilation of multicall, using the obj_call
+(defmethod compile_obj ((cod prog_multicall) env)
+  (let ( (pformalist (prog_multicall-multicall_formals cod)) 
+	 (pcall (prog_multicall-multicall_call cod))
+	 (pbody (prog_multicall-multicall_body cod)) 
+	 (newenv (cold_fresh_env env))
+	 (revinstrseq nil)
+	 (revresultvars nil)
+	 ) 
+    (assert (or (prog_apply-p pcall) (prog_send-p pcall)))
+    (flet ( 
+	   (handleformalbind 
+	    (bnd)
+	    (let ( (bname (cold_any_binding-bname bnd))
+		   (btype (cold_typed_binding-type bnd))
+		   )
+	      (case btype
+		    (:value 
+		     (let ( (vvar 
+			     (newobjptrvar (compilation-currout this_compilation) bnd 
+					   "multicall value"
+					   )) )
+		       (cold_put_binding 
+			(make-cold_value_binding :bname bname :val vvar :type btype) 
+			newenv)
+		       (push (build_obj_compute vvar (list "(void*)0") btype) 
+			     revinstrseq)
+		       (push vvar revresultvars)
+		       ))
+		    (:long
+		     (let ( (nvar 
+			     (newobjlongvar (compilation-currout this_compilation) bnd 
+					    "multicall long"
+					 )) )
+		       (cold_put_binding
+			(make-cold_value_binding :bname bname :val nvar :type btype)
+			newenv)
+		       (push (build_obj_compute nvar (list "0L") btype) 
+			     revinstrseq)
+		       (push nvar revresultvars)
+		       ))
+		    (otherwise (error "compile_obj prog_multicall unexpected bnd ~S"
+				      bnd))))
+	    ))
+	  (mapc (function handleformalbind) pformalist)
+	  )
+    (let* ( (resultvars (reverse revresultvars)) 
+	    )
+      (cond
+       ( (prog_apply-p pcall)
+	 (push (make-obj_call 
+		:dest (first resultvars)
+		:clos (compile_obj (prog_apply-appl_fun pcall) env)
+		:xtraresults (rest resultvars)
+		:args (mapcar (lambda (e) (compile_obj e env))
+			      (prog_apply-appl_args pcall))
+		) revinstrseq))
+       ( (prog_send-p pcall)
+	 (push (make-obj_send
+		:obs_dest (first resultvars)
+		:obs_sel (compile_obj (prog_send-send_sel pcall) env)
+		:obs_recv (compile_obj (prog_send-send_recv pcall) env)
+		:obs_args   (mapcar (lambda (e) (compile_obj e env))
+				    (prog_send-send_args pcall))
+		:obs_xtraresults (rest resultvars)
+		) revinstrseq))
+       ( t
+	 (error "unexpected call ~S in multicall" pcall))
+       )
+      )
+    (mapc (lambda (e) (push (compile_obj e newenv) revinstrseq)) pbody)
+    (make-obj_block
+     :instrs (reverse revinstrseq))
+    ))
+
+;;;;;;;;;;;;;;;;;;; compilation of toplev definitions
+
+(defmethod compile_obj ((cod prog_defun) env)
+  (push cod (compilation-functions this_compilation))
+  ;; (format *error-output* "compile_obj prog_defun cod <ici> ~S~%" cod)
+  (let* (
+	 ;; if the defun originated from a lambda, we do not need to
+	 ;; build a dataclosure
+	 (slambda (prog_defun-fun_lambda cod))
+	 (orout (make-obj_routine 
+		 :pfun cod 
+		 :nbptr 1 		;reserve slot for result ptr
+		 :nbnum 0 
+		 :nbdouble 0 
+		 :obody nil
+		 :syname  (prog_def-def_name cod)
+		 :rank (length  (compilation-functions this_compilation))
+		 :data2ptrhash (make-hash-table :size 31)
+		 )) 
+	 (odatarout (add_cdata (make-obj_dataroutine
+				:comname (prog_def-def_name cod)
+				:discr 'DISCR_ROUTINE
+				:rout orout
+				)
+			       "defun datarout"
+			       ))
+	 (funbind (and 
+		   (null slambda)
+		   (cold_find_binding  (prog_def-def_name cod) env)
+		   ))
+	 (odatacl (and 
+		   (null slambda)
+		   (cold_function_binding-p funbind)
+		   (let ( (ofunclo (cold_function_binding-fclodata funbind)) )
+		     (assert (obj_dataclosure-p ofunclo))
+		     (setf (obj_dataclosure-rout ofunclo) orout)
+		     (setf (obj_dataclosure-discr ofunclo) 'DISCR_CLOSURE)
+		     (add_cdata ofunclo "defun dataclo")
+		     )))
+	 (oarginsrev nil)
+	 (fbind (prog_defun-fun_argbindings cod)) 
+	 (newenv (cold_fresh_env env))
+	 (oldcurrout (compilation-currout this_compilation))
+	 )
+    (setf (obj_routine-dataclos orout) odatacl)
+    (setf (obj_routine-datarout orout) odatarout)
+    (setf (compilation-currout this_compilation) orout)
+    ;; bind the name to the dataclosure if available
+    (if odatacl 
+	(cold_put_binding 
+	 (make-cold_value_binding  :bname  (prog_def-def_name cod) 
+				   :val odatacl :type ':value)
+	 env))
+    (cold_delay
+     (format nil "compilobj defun ~S closvar"  (prog_def-def_name cod))
+     (if odatacl 
+	 (setf (obj_dataclosure-clodata odatacl)
+	       (mapcar (lambda (var) (handleclosvar var env)) 
+		       (prog_defun-fun_closvars cod))))
+     (mapcar (lambda (var) 
+	       (push 
+		(handleclosvar var env)
+		(obj_dataroutine-roudata odatarout)
+		)) 
+	     (prog_defun-fun_constants cod)))
+    (labels
+     ( (bindvar (nam val type) 
+		(let ( (nbi (make-cold_value_binding 
+			     :bname nam :val val :type type))) 
+		  (cold_put_binding nbi newenv
+				    )))
+       ( doptr (b) 			;add a value arg
+	       (let ( (ovar (newobjptrvar orout b
+					  "defun doptr"
+					  )) )
+		 (bindvar (cold_formal_binding-bname b) ovar ':value)
+		 (push (make-obj_getptrarg_instr
+			:dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
+		 ) )
+       ( dolong (b) 			;add a numerical arg
+		(let ( (ovar (newobjlongvar orout b  
+					    "defun dolong"
+					 )) )
+		  (bindvar (cold_formal_binding-bname b) ovar ':long)
+		  (push (make-obj_getlongarg_instr 
+			 :dest ovar :rk (cold_formal_binding-rank b)) oarginsrev)
+		  ) )
+       ( doit (b)			;handle both
+	      (case (cold_formal_binding-type b)
+		    (:value (doptr b))
+		    (:long (dolong b))
+		    (otherwise (error "compile_obj progdefun unexpected binding ~s" b)))
+	      )
+       (comp1 (i)			;compile 1 instruction
+	      (compile_obj i newenv)
+	      )
+       (comp (i)			;compile 1 or many instr
+	     (if (listp i) (mapcar #'comp1 i) (comp1 i))
+	     )
+       )
+     (mapcar (function doit) fbind)
+     (let* ( (funbody (prog_defun-fun_body cod)) ;compile the entire body
+	     (objbody (comp funbody)) 
+	     (insarg (make-obj_get_arguments :instrs (reverse oarginsrev))) )
+;;; put the proper list of instructions
+       (setf (obj_routine-obody orout)
+	     (if (listp objbody) (cons insarg objbody) (list insarg objbody)))
+;;; restore compilation & return the routine
+       (setf (compilation-currout this_compilation) oldcurrout)
+       orout
+       ))))
+
+
+;;;; compilation of a primitive
+(defmethod compile_obj ((cod prog_defprimitive) env)
+  ;; create an object with 3 fields: the name, the formal tuple, the expansion tuple
+  (let* 
+      (
+       (pname (prog_def-def_name cod))
+       (pformals (prog_defprimitive-primitive_formals cod))
+       (ptype (prog_defprimitive-primitive_type cod))
+       (pexpand (prog_defprimitive-primitive_expansion cod))
+       (onamestr (add_cdata (make-obj_datastring
+			     :comname pname
+			     :discr 'DISCR_STRING 
+			     :string (string pname))
+			    "defprimit namstr"
+			    ))
+       (oformals 
+	(mapcar 
+	 (lambda (forbi)
+	   (add_cdata (make-obj_datainstance
+		       :comname pname
+		       :discr 'CLASS_FORMAL_BINDING
+		       :slots (list 
+			       (get_obj_symbol (cold_formal_binding-bname forbi) "defprimi forbi")
+			       (get_obj_type (cold_formal_binding-type forbi)))
+		       )
+		      "defprimit formal"
+		      ))
+	 pformals))
+       (oexptuple 
+	(add_cdata 
+	 (make-obj_datamultiple
+	  :comname pname
+	  :discr 'DISCR_MULTIPLE
+	  :values 
+	  (mapcar 
+	   (lambda (e)
+	     (cond 
+	      ((symbolp e)
+		    (let ((po (position-if
+			       (lambda (bi) (eq (cold_formal_binding-bname bi) e))
+			       pformals)))
+		      (or po 
+			  (error "unexpected symbol ~S in defprimitive ~S" e cod))
+		      (nth po oformals)
+		      )
+		    )
+	      ((stringp e)
+	       (add_cdata (make-obj_datastring
+			   :comname pname
+			   :discr 'DISCR_STRING 
+			   :string e)
+			  "defprimit string"
+			  ))
+	      (t (error "unexpected stuff ~S in defprimitive ~S" e cod))
+	      ))
+	     pexpand))
+	 "defprimit exptuple"
+	 ))
+       (oformaltuple
+	(add_cdata
+	 (make-obj_datamultiple
+	  :comname (prog_def-def_name cod)
+	  :discr 'DISCR_MULTIPLE
+	  :values oformals)
+	 "defprimit formtuple"
+	 ))
+       (oprim (add_cdata (make-obj_datainstance 
+			  :comname pname
+			  :discr 'CLASS_PRIMITIVE
+			  :slots (list nil onamestr oformaltuple oexptuple))
+			 "defprimit oprim"
+			 )
+	      )
+       )
+    nil
+    ))
+
+
+
+
+;; recursive ancestors in reversed order
+(defun revancestors_defclass (dc)
+  (if dc 
+      (let 
+	  ((supdc (prog_defclass-class_super dc)))
+	(if supdc (cons supdc (revancestors_defclass supdc))))))
+
+;; recursive fields in reversed order
+(defun revfields_defclass (dc)
+  (if dc 
+      (let ((supdc (prog_defclass-class_super dc)))
+	(revappend (prog_defclass-class_ownfields dc) (revfields_defclass supdc)))))
+
+
+;;;;; compilation of a defclass
+(defmethod compile_obj ((cod prog_defclass) env)
+  (let (
+	(pname (prog_def-def_name cod))
+	(ppredef (prog_predef-predef_rank cod))
+	(allfields (reverse (revfields_defclass cod)))
+	(allancestors (reverse (revancestors_defclass cod)))
+	)
+    (let* (
+	   (obstrname (add_cdata 
+		       (make-obj_datastring
+			:comname pname
+			:discr 'DISCR_STRING :string (string pname))
+		       "defclass strname"
+		       )) 
+	   (obclass (add_cdata 
+		     (make-obj_datainstance 
+		      :comname pname
+		      :discr 'CLASS_CLASS
+		      :predef ppredef
+		      :objnum 'OBMAG_OBJECT)
+		     "defclass obclass"
+		     ))
+	   (clabind (cold_find_binding (prog_defclass-def_name cod) env))
+	   (obancestorstuple 
+	    (add_cdata 
+	     (make-obj_datamultiple
+	      :comname (prog_def-def_name cod)
+	      :discr 'DISCR_SEQCLASS
+	      :values 
+	      (mapcar
+	       (lambda (anc) 
+		 (assert (prog_defclass-p anc))
+		 (let* ( (ancbind (cold_find_binding 
+				   (prog_defclass-def_name anc) env))
+			 (ancdata (cold_class_binding-classdata ancbind))
+			 )
+		   ancdata
+		   ))
+	       allancestors)
+	      )
+	     "defclass seqancestors"
+	     ))
+	   (obsuper 
+	    (if allancestors
+		(let* (
+		       (anc (first (last allancestors)))
+		       (ancbind (cold_find_binding 
+				 (prog_defclass-def_name anc) env))
+		       (ancdata (cold_class_binding-classdata ancbind))
+		       )
+		  ancdata
+		  )))
+	   (obfieldstuple 
+	    (add_cdata 
+	     (make-obj_datamultiple
+	      :comname (prog_def-def_name cod)
+	      :discr 'DISCR_SEQFIELD
+	      :values  
+	      (mapcar
+	       (lambda (f) 
+		 (assert (prog_field-p f))
+		 (let ( (fldata
+			 (add_cdata 
+			  (make-obj_datainstance 
+			   :comname (prog_field-def_name f)
+			   :discr 'CLASS_FIELD
+			   :objnum (prog_field-field_offset f)
+			   :slots
+			   (list nil 
+				 (add_cdata 
+				  (make-obj_datastring
+				   :comname (prog_def-def_name f)
+				   :discr 'DISCR_STRING
+				   :string (string (prog_def-def_name f))))
+				 nil))))
+			(flbind
+			 (cold_find_binding (prog_field-def_name f) env))
+			)
+		   (assert (cold_field_binding-p flbind))
+		   (setf (cold_field_binding-fieldata flbind) fldata)
+		   )
+		 )
+	       allfields)
+	      )
+	     "defclass fieldtupl"
+	     ))
+	   )
+      (setf (cold_class_binding-classdata clabind) obclass)
+      (setf (obj_datainstance-slots obclass) 
+	    (list 
+	     nil			;no prop
+	     obstrname
+	     nil			;no methodict
+	     nil 			;no sendclosure
+	     obsuper			;disc_super
+	     obancestorstuple
+	     obfieldstuple
+	     nil			;no objnumdescr
+	     nil			;nod classdata
+	     ))
+      nil				;result of compile_obj
+      )))
+
+
+;;; compile a definstance (not a defselector!)
+(defmethod compile_obj ((cod prog_definstance) env)
+  (let ( (iname (prog_def-def_name cod))
+	 (ipredef (prog_predef-predef_rank cod))
+	 (iclass (prog_definstance-inst_class cod))
+	 (iobjnum (prog_definstance-inst_objnum cod))
+	 (islots (prog_definstance-inst_slots cod)) )
+    (assert (prog_defclass-p iclass))
+    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
+	   (insbind (cold_find_binding iname env))
+	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
+	   )
+      (assert (cold_instance_binding-p insbind))
+      (assert (cold_class_binding-p clabind))
+      (assert (cold_class_binding-classdata clabind))
+      (let ( (ob
+	      (make-obj_datainstance 
+	       :comname (prog_def-def_name cod)
+	       :discr (cold_class_binding-classdata clabind)
+	       :objnum 
+	       ;;special hack for OBMAG_* names or others
+	       (if (symbolp iobjnum) iobjnum
+		 (compile_obj iobjnum env))
+	       :predef ipredef))
+	     ) 
+	(add_cdata ob "definstance ob")
+	(setf (cold_instance_binding-instancedata insbind) ob)
+	;; fill the slot, should be here to allow
+	;; a slot to refer to the newly made
+	;; instance
+	(mapc (lambda (s)
+		(setf (aref slovec 
+			    (prog_field-field_offset (instance_slot-slot_field s)) )
+		      (let* ( (cobs 
+			       (compile_obj (instance_slot-slot_value s) env)) 
+			      ;; we put the tempslot variable as destination
+			      (pobs
+			       (put_destination cobs cold_tempslot_var))
+			      )
+			(or pobs cobs)
+			)))
+	      islots)
+	(setf (obj_datainstance-slots ob)
+	      (concatenate 'list slovec)) ;; convert slovec to a list
+	ob
+	)
+      )
+    nil))
+
+;;; compile a defselector is quite similar to a definstance
+(defmethod compile_obj ((cod prog_defselector) env)
+  (let ( (iname (prog_def-def_name cod))
+	 (ipredef (prog_predef-predef_rank cod))
+	 (iclass (prog_definstance-inst_class cod))
+	 (iobjnum (prog_definstance-inst_objnum cod))
+	 (islots (prog_definstance-inst_slots cod)) )
+    (assert (prog_defclass-p iclass))
+    (let ( (slovec (make-array (length (prog_defclass-class_allfields iclass)))) 
+	   (insbind (cold_find_binding iname env))
+	   (clabind (cold_find_binding (prog_def-def_name iclass) env))
+	   )
+      (assert (cold_selector_binding-p insbind))
+      (assert (cold_class_binding-p clabind))
+      (assert (cold_class_binding-classdata clabind))
+      (let ( (ob
+	      (make-obj_datainstance 
+	       :comname (prog_def-def_name cod)
+	       :discr (cold_class_binding-classdata clabind)
+	       :objnum 
+	       ;;special hack for OBMAG_* names or others
+	       (if (symbolp iobjnum) iobjnum
+		 (compile_obj iobjnum env))
+	       :predef ipredef))
+	     ) 
+	(add_cdata ob "defselector ob")
+	(setf (cold_selector_binding-selectordata insbind) ob)
+	;; fill the slot, should be here to allow
+	;; a slot to refer to the newly made
+	;; instance
+	(mapc (lambda (s)
+		(setf (aref slovec 
+			    (prog_field-field_offset (instance_slot-slot_field s)) )
+		      (let* ( (cobs 
+			       (compile_obj (instance_slot-slot_value s) env)) 
+			      ;; we put the tempslot variable as destination
+			      (pobs
+			       (put_destination cobs cold_tempslot_var))
+			      )
+			(or pobs cobs)
+			)))
+	      islots)
+	(setf (obj_datainstance-slots ob)
+	      (concatenate 'list slovec)) ;; convert slovec to a list
+	ob
+	)
+      )
+    nil))
+
+
+
+
+;; get (and generate if needed) the objinstance for a symbol
+(defun get_obj_symbol (sym &optional why) 
+  (assert (symbolp sym) (sym) "bad argument to get_obj_symbol ~S" sym)
+  (let ((sydict (compilation-symboldict this_compilation)))
+    (or (gethash sym sydict) 
+	(let* ( 
+	       (onamestr (add_cdata (make-obj_datastring
+				     :comname sym
+				     :discr 'DISCR_STRING 
+				     :string (string sym))
+				    (if why (concatenate 'string "GetObjSymb namstr " why)
+				      "getobjsymb namstr")
+				    ))
+	       (osym (add_cdata (make-obj_datainstance
+				 :discr (if (keywordp sym) 'CLASS_KEYWORD 'CLASS_SYMBOL)
+				 :comname sym
+				 :slots (list nil onamestr nil))
+				(if why (concatenate 'string "GetObjSymb osym " why)
+				  "getobsymb osym")
+				))
+	       )
+	  (setf (gethash sym sydict) osym)
+	  osym
+	  )
+	#|				;
+	(let* ( (odatasym  (make-obj_dataqsymbol :comname sym :qsymb sym)) 
+	(osym (or (currout_data2ptr odatasym) (newobjconst odatasym))) )
+	(setf (gethash sym sydict) osym)
+	osym
+	)
+	|#
+)))
+
+;; translate a type
+(defun get_obj_type (ty)
+  (case ty
+	(:value 'CTYPE_VALUE)
+	(:long 'CTYPE_LONG)
+	(:cstring 'CTYPE_CSTRING)
+	(t (error "bad type to get_obj_type ~S" ty))))
+
+
+
+;;;;;;;;;;;;;;;;;;; compilation of instructions
+(defmethod compile_obj ((cod prog_let) env)
+  (let ( (lbind (prog_let-let_bindings cod))
+	 (lbody (prog_let-let_body cod)) 
+	 (newenv (cold_fresh_env env))
+	 (locptrvars nil)		;list of local pointers vars (to be freed & cleared)
+	 (loclongvars nil)		;list of local long vars (to be freed & cleared)
+	 (revinstrseq nil)
+	 )
+    (labels 
+	( (checkbinding 
+	   (bnd)			; compute the type of each binding if it didn't have one
+	   (assert (cold_let_binding-p bnd))
+	   (if (null (cold_let_binding-type bnd))
+	       (let ( (bexpr (cold_let_binding-expr bnd)) )
+		 (cond ( (prog_primitive-p bexpr) 
+			 (setf (cold_let_binding-type bnd) 
+			       (prog_defprimitive-primitive_type
+				(prog_primitive-prim_oper bexpr)))
+			 )
+		       ( (and (atom bexpr)
+			      (cold_find_binding bexpr env))
+			 (let ( (exbnd (cold_find_binding bexpr env)) )
+			   (and 
+			    (cold_typed_binding-p exbnd)
+			    (cold_typed_binding-type exbnd)
+			    (setf (cold_let_binding-type bnd) 
+				  (cold_typed_binding-type exbnd))
+			    )
+			   )
+			 ))))
+	   ;; by default set the type to :value
+	   (if (null (cold_let_binding-type bnd))
+	       (setf (cold_let_binding-type bnd) ':value))
+	   )
+	  (handlebinding
+	   (bnd)
+	   (let ( (bexpr (cold_let_binding-expr bnd)) 
+		  (btype (cold_typed_binding-type bnd)) 
+		  (bname (cold_any_binding-bname bnd))
+		  )
+	     (case btype
+	       (:value 
+		(let ( (vvar 
+			(newobjptrvar (compilation-currout this_compilation) bnd 
+				      "compilet ptr" )) )
+		  (push vvar locptrvars)
+		  (cold_put_binding 
+		   (make-cold_value_binding :bname bname :val vvar :type btype) 
+		   newenv)
+		  (let ( (compexp  
+			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
+		    (push (or (put_destination compexp vvar) compexp) revinstrseq)
+		    )))
+	       (:long 
+		(let ( (nvar 
+			(newobjlongvar (compilation-currout this_compilation) bnd 
+				       "compilet long")) )
+		  (push nvar loclongvars)
+		  (cold_put_binding
+		   (make-cold_value_binding :bname bname :val nvar :type btype)
+		   newenv)
+		  (let ( (compexp  
+			  (compile_obj  (cold_let_binding-expr bnd) newenv)) )
+		    (push (or (put_destination compexp nvar) compexp) revinstrseq)
+		    )))
+	       (:void
+		;; dont use any objvar and dont putdest
+		(cold_put_binding
+		 (make-cold_value_binding :bname bname :val nil :type btype)
+		 newenv)
+		(let ( (compexp  
+			(compile_obj  (cold_let_binding-expr bnd) newenv)) )
+		  (push compexp revinstrseq)
+		  ))
+	       (otherwise (error "compile_obj prog_let unexpected binding ~s" bnd))
+	       )
+	     )
+	   )
+	  (comp1 
+	   (cod)
+	   (push (compile_obj cod newenv) revinstrseq)
+	   )
+	  (comp 
+	   (cod)
+	   (if (listp cod) (mapcar (function comp1) cod) (comp1 cod)))
+	  )
+      (mapc (function checkbinding) lbind)
+      (mapc (function handlebinding) lbind)
+      (comp lbody)
+      (let ( (lbc (first revinstrseq)) );; lbc is the last body compiled ...
+       ;;; generates clears only if the compiled body is a variable
+       ;;; which we don't clear
+	(mapcar (lambda (pv) 
+		  (if (and (obj_var-p lbc) (not (eql lbc pv)))
+		      (push (make-obj_clearptr :clrptrvar pv) revinstrseq))
+		  (freeobjptrvar pv)
+		  ) locptrvars)
+	(mapcar (lambda (lv)
+		  (if (and (obj_var-p lbc) (not (eql lbc lv)))
+		      (push (make-obj_clearlong :clrlongvar lv) revinstrseq))
+		  (freeobjlongvar lv)
+		  ) loclongvars)
+	;;; push again the lbc to make it the result of the block
+	(if (obj_var-p lbc)
+	    (push lbc revinstrseq))))
+    (make-obj_block :instrs (reverse revinstrseq))
+    )
+  )
+
+(defmethod compile_obj ((cod prog_primitive) env)
+  (error "unexpected call to compile_obj prog_primitive cod ~S env ~S" cod env)
+  )
+
+(defmethod compile_obj ((cod prog_chunk) env)
+  (let* ( (chargs (prog_chunk-chunk_args cod)) 
+	  (objc (build_obj_compute 
+		 nil
+		 (mapcar (lambda (a)
+			   (cond ((stringp a) (make-obj_verbatim :vstr a))
+				 ((numberp a) a)
+				 (t (compile_obj a env)))
+			   )
+			 chargs)
+		 (prog_chunk-chunk_type cod)
+		 )) )
+    objc
+    ))
+
+
+(defmethod compile_obj ((cod prog_unsafe_get_field) env)
+  (let* ( (ugfield (prog_unsafe_get_field-uget_field cod))
+	  (ugobj (prog_unsafe_get_field-uget_obj cod)) )
+    (assert (prog_field-p ugfield))
+    (build_obj_compute
+     nil
+     (list "/*unsafe_get*/ (basilys_field_object(("
+	   (compile_obj ugobj env)
+	   "), ("
+	   (prog_field-field_offset ugfield)
+	   "))"
+	   (format nil "/**.~a.**/" (prog_field-def_name ugfield))
+	   ")"
+	   )
+     :value
+     )))
+
+
+(defmethod  compile_obj ((cod prog_unsafe_put_fields) env)
+  (let* ( (upobj (prog_unsafe_put_fields-uput_obj cod))
+	  (upkeys (prog_unsafe_put_fields-uput_keys cod))
+	  (revinstrs nil) )
+    ;; push the destination in a register
+    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register basilysobject_ptr_t obdest= 0;")
+	  revinstrs)
+    (push (make-obj_verbatiminstr :vstr "/*unsafeput dest*/register int oblen= 0;")
+	  revinstrs)
+    (push 
+     (build_obj_compute
+      nil
+      (list "/*unsafe_put setdest*/ obdest = (void*)"
+	    (compile_obj upobj env))
+      :value
+      )
+     revinstrs)
+    (push (make-obj_verbatiminstr :vstr "gcc_assert(basilys_magic_discr(obdest) == OBMAG_OBJECT);")
+	  revinstrs)
+    (push (make-obj_verbatiminstr :vstr "oblen = basilys_object_length(obdest);")
+	  revinstrs)
+    (let ( (maxfldoff 0) )
+      (loop
+       for curkpair in upkeys do
+       (let ( (curfld (car curkpair))
+	      (curexp (cdr curkpair))
+	      )
+	 (assert (prog_field-p curfld))
+	 (setq maxfldoff (max maxfldoff (prog_field-field_offset curfld)))
+       ))
+    (push (make-obj_verbatiminstr :vstr (format nil "gcc_assert(oblen > ~d);" maxfldoff))
+	  revinstrs)
+      )
+    ;; push the field initializations
+    (mapc 
+     (lambda (curkpair)
+       (let ( (curfld (car curkpair))
+	      (curexp (cdr curkpair))
+	      )
+	 (assert (prog_field-p curfld))
+	 (push
+	  (build_obj_compute
+	   nil
+	   (list
+	    "/*unsafe_put field*/ obdest->obj_vartab["
+	    (prog_field-field_offset curfld)
+	    "] "
+	    (format nil "/**.~a.**/" (prog_field-def_name curfld))
+	    " = (basilys_ptr_t)(" 
+	    (compile_obj curexp env)
+	    ")"
+	    )
+	   :value
+	   )
+	  revinstrs)
+	 ))
+     upkeys)
+    ;; push the touch of the destination
+    (push
+     (build_obj_compute 
+      nil
+      (list "/*unsafe_put touch*/ basilysgc_touch(obdest)")
+      :void
+      )
+     revinstrs)
+    ;; push the destination itself as the result
+    (push
+     (compile_obj upobj env)
+     revinstrs)
+    ;; return the block
+    (make-obj_block :instrs (reverse revinstrs))
+    ))
+
+
+(defmethod compile_obj ((cod prog_make_instance) env)
+  (let ( (classv (prog_make_instance-mki_class cod)) 
+	 (mikeys (prog_make_instance-mki_keys cod)) 
+	 (classd (prog_make_instance-mki_classdef cod))
+	 (revinstrs nil)
+	 )
+    ;; push the destination in a register
+    (push (make-obj_verbatiminstr :vstr "/*makeinst*/register basilysobject_ptr_t obnew= 0;")
+	  revinstrs)
+    (let ( (compclass (compile_obj classv env)) 
+	   (siznew  (length (prog_defclass-class_allfields classd)))
+	   )
+      (if (and (compilation-currout this_compilation)
+	       (obj_data-p compclass))
+	  (setq compclass (newobjconst compclass "makeinst class")))
+					;      (warn "compile_obj make_instance cod ~S compclass ~S env ~S ~%...compilobj make_inst currout ~S" 
+					;	     cod compclass env (compilation-currout this_compilation))
+      (push 
+       (build_obj_compute
+	nil
+	(list "/*make_instance*/obnew = basilysgc_new_raw_object( (void*)"
+	      compclass
+	      "," 
+	      siznew
+	      ")")
+	:value
+	)
+       revinstrs)
+      ;; push the field initializations
+      (mapc 
+       (lambda (curkpair)
+	 (let ( (curfld (car curkpair))
+		(curexp (cdr curkpair))
+		)
+	   (assert (prog_field-p curfld))
+	   (assert (< (prog_field-field_offset curfld) siznew))
+	   (push
+	    (build_obj_compute
+	     nil
+	     (list
+	      "/*make_inst field*/ obnew->obj_vartab["
+	      (prog_field-field_offset curfld)
+	      "] "
+	      (format nil "/**.~a.**/" (prog_field-def_name curfld))
+	      " = (basilys_ptr_t)(" 
+	      (compile_obj curexp env)
+	      ")"
+	      )
+	     :value
+	     )
+	    revinstrs)
+	   ))
+       mikeys)
+      )
+    ;; push the new object itself as the result
+    (push
+     (make-obj_verbatim :vstr "obnew")
+     revinstrs)
+    ;; return the block
+    (make-obj_block :instrs (reverse revinstrs))
+    ))
+
+
+(defun compile_argobj (cod env)
+  (if (stringp cod) 
+      (let*  ( (obstrdata 
+		(add_cdata (make-obj_datastring
+			    :comname cod
+			    :discr 'DISCR_STRING
+			    :string cod)
+			   "argobj strdata")
+		) 
+	       (constri (newobjconst obstrdata "argobj constri")) 
+	       )
+	;;; (warn "compile_argobj cod ~S obstrdata ~S constr ~S env ~S~%" cod obstrdata constri env)
+	constri) 
+    (compile_obj cod env)
+  ))
+
+
+(defmethod compile_obj ((cod prog_apply) env)
+  (let ( (apfun (prog_apply-appl_fun cod))
+	 (apargs (prog_apply-appl_args cod)) )
+    (make-obj_call
+     :clos (compile_obj apfun env)
+     :args (mapcar (lambda (c) (compile_argobj c env)) apargs)
+     )
+    )
+)
+
+(defmethod compile_obj ((cod prog_send) env)
+  (let ( (isel (prog_send-send_sel cod))
+	 (irecv (prog_send-send_recv cod))
+	 (iargs (prog_send-send_args cod)) )
+    (make-obj_send
+     :obs_dest nil
+     :obs_sel (compile_obj isel env)
+     :obs_xtraresults nil
+     :obs_recv (compile_obj irecv env)
+     :obs_args  (mapcar (lambda (c) (compile_argobj c env)) iargs)
+     )
+))
+
+
+
+
+(defmethod compile_obj ((cod prog_lambda) env)
+  (error "should never be called compile_obj prog_lambda cod=~S ~%" cod)
+)
+
+
+(defmethod compile_obj ((cod prog_makeclosure) env)
+  (flet 
+      ( (comp (c) (compile_obj c env)) )
+    (let* 
+	( (cfun (prog_makeclosure-mkclos_fun cod)) 
+	  (cvars (prog_makeclosure-mkclos_closvars cod))
+	  (mkc
+	   (make-obj_mkclosure 
+	    :cfun cfun
+	    :cvals (mapcar (function comp) cvars)
+	    ) 
+	   )
+	  )
+      (let ((obr 
+	     (find-if 
+	      (lambda (o) 
+		(and (obj_dataroutine-p o)
+		     (eq (obj_routine-pfun (obj_dataroutine-rout o)) cfun)))
+	      (compilation-cdata this_compilation))))
+	(or obr (error "compile_obj makeclosure ~S ~%..cannot find dataroutine for ~S"
+		       cod cfun))
+	(setf (obj_mkclosure-kobjrout mkc) (newobjconst obr "makeclos objro"))
+	mkc
+	))))
+
+
+
+(defmethod compile_obj ((cod prog_return) env)
+  (let ( (progrets (prog_return-retexprs cod)) )
+    (or (listp progrets) (error "bad prog_return without list return ~s" cod))
+    (let ( (compexprs (mapcar (lambda (c) (compile_obj c env)) progrets)) )
+      (let ( (retmain (and (consp compexprs) (first compexprs))) 
+	     (retextras (and (consp compexprs)  (rest compexprs))) )
+	(and (prog_src-p retmain) (not (eq (query_ctype retmain) :value))
+	     (error "prog_return has bad main value ~s" cod))
+	(if retmain
+	    (progn
+;	      (warn "compilobjreturn retmain ~S retextras ~S~%" retmain retextras)
+	      (let ( (newretmain (put_destination retmain cold_return_var)) )
+	      (if newretmain (setq retmain newretmain)))))
+	(make-obj_return
+	 :mainreturn retmain
+	 :extrareturns retextras)
+   )
+)))
+
+
+(defmethod compile_obj ((cod prog_setq) env)
+  (let* ( (pva (prog_setq-setq_var cod))
+	  (pex (prog_setq-setq_expr cod)) 
+	  (cva (compile_obj pva env))
+	  (cex (compile_obj pex env))
+	  (typcva (query_ctype cva))
+	  (typcex (query_ctype cex))
+	  )
+    (and typcva typcex 
+	 (or (eq typcva typcex)
+	     (error "setq incompatible type cod ~S~%.. cva ~S~%.. cex ~S~%" cod cva cex)))
+    (if (consp cex) (error "setq multi-expr cod ~S cex ~S" cod cex))
+    (if (obj_var-p cva)
+	(build_obj_compute
+	 cva
+	 (if (listp cex) cex (list cex))
+	 typcex
+	 )
+      (make-obj_closetq
+       :cldest cva
+       :val cex)
+      )))
+
+
+(defmethod compile_obj ((cod prog_if) env)
+  (let ( (pcond (prog_if-cond_expr cod))
+	 (pthen (prog_if-then_expr cod)) 
+	 (pelse (prog_if-else_expr cod)) )
+    (let ( (ocond (compile_obj pcond env))
+	   (othen (and pthen (compile_obj pthen env)))
+	   (oelse (and pelse (compile_obj pelse env))) )
+      (if (and othen oelse) 
+	  (let ( (thenctype (if othen (or (query_ctype othen) :value)))
+		 (elsectype (if oelse (or (query_ctype oelse) :value))) )
+	    (or 
+	     (eq thenctype elsectype)
+	     (eq thenctype ':void)
+	     (eq elsectype ':void)
+	     (warn "if incompatible type cod ~S~%.. othen ~S~%... thenctype ~S ~%.. oelse ~S~%... elsectype ~S~%"
+		   cod othen  thenctype oelse elsectype))))
+      (make-obj_if
+       :ob_cond ocond
+       :ob_then othen
+       :ob_else oelse
+       )
+      )))
+
+
+
+
+;;;;;;;;;;;;; parsing a source file
+(defun ctime ()
+  (multiple-value-bind
+   (second minute hour date month year day-of-week dst-p tz)
+   (get-decoded-time)
+   (format nil "~4,'0d ~a ~2,'0d @ ~2,'0d:~2,'0d:~2,'0d (GMT~@d)"
+	   year (nth month '("???" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
+			     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+	   date hour minute second tz))
+)
+
+
+(defun compile_toplev (cod freshenv)
+  ;; if it is a definition, compile it
+  (if (prog_def-p cod)
+      (progn
+;	(format *error-output* "compile_toplev def cod=~S" cod)
+	(let ( (ce (compile_obj cod freshenv)) )
+;	  (format  *error-output* "compile_toplev def ce=~S" cod)
+	  (if ce (add_objcode ce))
+	  )
+	)
+    ;; not a definition, compile it appropriately and add it to the
+    ;; initial routine's body
+    (let* ( 
+	   (oldcurrout (compilation-currout this_compilation))
+	   (initrout (compilation-initrout this_compilation))
+	   (initbody (obj_routine-obody initrout))
+	   )
+      (setf (compilation-currout this_compilation) initrout)
+;      (format *error-output* "compile_toplev avant compile_obj cod=~S~%" cod)
+      (let ( (ce (compile_obj cod freshenv)) )
+;	(format *error-output* "compile_toplev apres compile_obj cod=~S ce=~S~%" cod ce)
+	(if ce (setf (obj_routine-obody initrout)
+		     (append initbody (list ce))))
+	)
+      (setf (compilation-currout this_compilation) oldcurrout)
+      )))
+
+
+;; limit the CPU time to 1000 sec on Clisp
+;; sometimes a clisp.run process remains.... eg when killing xemacs...
+#+CLISP
+(setf (posix:rlimit :cpu) (values 1000 1200))
+
+(defun handle-source-file (filename)
+  (with-open-file
+   (istr filename)
+   (format *error-output* "reading file ~s ~%" filename)
+   (let ( (*readtable* (copy-readtable)) 
+	  (readrevseq nil)
+	  (outpathname (make-pathname :name (pathname-name filename) :type "c"))
+	  )
+     (loop 
+      (let ((rditem (read istr nil)))
+	(if (null rditem)
+	    (return)
+	  (push rditem readrevseq) 
+	  )
+	)
+      )
+     (let* ( (readseq (reverse readrevseq)) 
+	     (initrout (make-obj_initroutine 
+			:nbptr 3
+			:nbnum 1
+			:nbdouble 0
+			:pfun 'init	
+			:data2ptrhash (make-hash-table :size 281)
+			:inirou_datarankdict  (make-hash-table :size 281)
+			)) 
+	     (thiscompil (make-compilation 
+			  :symboldict (make-hash-table)
+			  :initrout initrout
+			  )) 
+	     ) 
+       (setq this_compilation thiscompil)
+       (with-open-file
+	(outstr outpathname :direction :output :if-exists :rename)
+	(format outstr "/* generated file ~a on ~a */~%#include \"run-basilys.h\"~%" outpathname (ctime))
+	(format outstr "/*** read ~d inputs ***/ ~%~%" (length readseq)) 
+	(loop
+	 for rk from 1
+	 for curinp in readseq
+	 do 
+	 (format_c_comment outstr "++ input #~d~%~S~% ++~%~%" rk curinp))
+;	(finish-output outstr)
+	(format *error-output* "read ~d items from file ~s ~%" 
+		(length readseq) filename)
+	(let (  (freshenv  (cold_fresh_env cold_first_env))
+		)
+	  (labels 
+	   ( (expand-task 
+	      (inp)
+					; (cold_run_delayed_tasks "start expandtask")
+	      (let* ( 
+		     (exp (cold_macroexpand inp freshenv)) )
+		(cold_delay "normalize after expand" (normalize-task exp)))
+					; (cold_run_delayed_tasks "end expandtask")
+	      )
+	     (normalize-task 
+	      (exp)
+					; (cold_run_delayed_tasks "start normalizetask")
+	      (let ( (normexp (normalize_toplev exp freshenv)) )
+		(cold_delay "compile after normalize" (compile-task normexp))
+		)
+	      (cold_run_delayed_tasks "end normalizetask")
+	      )
+	     (compile-task
+	      (cod)
+					; (cold_run_delayed_tasks "start compiletask")
+;	      (finish-output outstr)
+	      (compile_toplev cod freshenv)
+	      (cold_run_delayed_tasks "end compiletask")
+	      )
+	     )
+	   (mapc (lambda (inp) (cold_delay "initial expand" (expand-task inp))) readseq)
+	   )				;end of labels
+	  (cold_run_delayed_tasks "initial")
+					; output the declarations
+	  (format *error-output* ";before writing ~d declarations ~g cpusec~%" 
+		  (length (compilation-revobjcode this_compilation))
+		  (cpusec))
+	  (loop
+	   for rk from 1
+	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
+	   do
+	   (format outstr "~%~%/*** declobj #~d ***/~%" rk)
+	   (output_cdecl ob outstr)
+	   ) 
+	  (cold_run_delayed_tasks "after decl")
+					; output the bodies
+	  (format *error-output* ";before writing ~d bodies ~g cpusecs~%" 
+		  (length (compilation-revobjcode this_compilation)) (cpusec))
+	  (loop
+	   for rk from 1
+	   for ob in (reverse  (compilation-revobjcode this_compilation)) 
+	   do
+	   (if (zerop (rem rk 32))
+	       (format *error-output* ";;writing body #~d of ~a : ~g cpusecs~%"
+		       rk (obj_routine-syname ob) (cpusec)))
+	   (format outstr "~%~%~%/*** obj #~d ***/~%" rk)
+	   (output_ccode ob outstr)
+;	   (finish-output outstr)
+	   )
+	  (cold_run_delayed_tasks "after bodies")
+	  (finish-output outstr)
+	  (format *error-output* ";before writing start routine ~g cpusecs~%" (cpusec))
+	  (cold_run_delayed_tasks "after initrout preparation")
+	  (format outstr "~%~%/*** initial routine is ***/~%")
+	  (output_cdecl initrout outstr)
+	  (finish-output outstr)
+	  (output_ccode initrout outstr)
+;	  (finish-output outstr)
+	  )
+	(finish-output outstr)
+	(format outstr "~%~%/*** end of generated file ~a ***/~%~%" outpathname)
+	)
+       (format *error-output* ";end of generation of ~S in ~g cpusecs- before basilys-gcc compilation~%" 
+	       outpathname (cpusec))
+       (finish-output *error-output*)
+       #+CLISP
+       (progn 
+	 (ext:run-program "indent" :arguments (list outpathname))
+	 (ext:run-program "basilys-gcc" :arguments (list outpathname))
+	 )
+       #+SBCL
+       (progn
+	 (sb-ext:run-program "/usr/bin/indent" (list outpathname))
+	 (sb-ext:run-program "/home/basile/scripts/basilys-gcc" (list outpathname))
+	 )
+       (format *error-output* ";end of basilys-gcc compilation of ~S in ~g cpusec~%" outpathname (cpusec))
+       (finish-output *error-output*)
+       ))))
+
+(setq *print-circle*  t)
+
+
+;; eof $Id: cold-basilys.lisp 289 2008-02-07 22:07:30Z basile $
diff --git a/contrib/simple-probe.c b/contrib/simple-probe.c
new file mode 100644
index 00000000000..96b51d78d2b
--- /dev/null
+++ b/contrib/simple-probe.c
@@ -0,0 +1,1496 @@
+/* Simple probe example (with GTK)
+   Copyright (C) 2008 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+/*
+This standalone program is a simple compiler probe client - it is a
+single source file using gtksourceview & gtk; it is not compiled by
+the GCC building process. The compilation command is given near the
+end of file (as a local.var to emacs)
+*/
+
+#define _GNU_SOURCE
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <string.h>
+#include <sys/mman.h>
+#include <ctype.h>
+
+#include <glib.h>
+#include <glib/gprintf.h>
+#include <gtk/gtk.h>
+#include <gtk/gtktextbuffer.h>
+#include <gtksourceview/gtksourceview.h>
+#include <gtksourceview/gtksourcelanguage.h>
+#include <gtksourceview/gtksourcelanguagesmanager.h>
+
+#define PROBE_PROTOCOL_NUMBER 200701
+
+/* from /usr/share/xemacs21/xemacs-packages/etc/ediff/ediff-next.xpm */
+/* XPM */
+static const char *arrow_right_15x15_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "15 15 5 1",
+  " 	c Gray75 s backgroundToolBarColor",
+  ".	c black",
+  "X	c white",
+  "o	c black",
+  "O	c black",
+  "               ",
+  "       .       ",
+  "       ..      ",
+  "       .X.     ",
+  " .......XX.    ",
+  " .XXXXXXXoX.   ",
+  " .XooooooooX.  ",
+  " .Xoooooooooo. ",
+  " .XooooooooO.  ",
+  " .oOOOOOOoO.   ",
+  " .......OO.    ",
+  "       .O.     ",
+  "       ..      ",
+  "       .       ",
+  "               ",
+};
+GdkPixbuf *arrow_right_15x15_pixbuf;
+
+/* from  /usr/share/xemacs21/xemacs-packages/etc/smilies/indifferent.xpm */
+static const char *indifferent_13x14_xpm[] = {
+  "13 14 3 1",
+  "       c None",
+  ".      c #000000",
+  "+      c #FFDD00",
+  "   .......   ",
+  "  ..+++++..  ",
+  " .+++++++++. ",
+  ".+++++++++++.",
+  ".++..+++..++.",
+  ".++..+++..++.",
+  ".+++++++++++.",
+  ".+++++++++++.",
+  ".+++++++++++.",
+  ".++.......++.",
+  ".+++++++++++.",
+  " .+++++++++. ",
+  "  ..+++++..  ",
+  "   .......   "
+};
+GdkPixbuf *indifferent_13x14_pixbuf;
+
+/* from /usr/share/xemacs21/xemacs-packages/lisp/speedbar/sb-info.xpm */
+/* XPM */
+static const char *sb_info_10x15_xpm[] = {
+  "10 15 4 1",
+  " 	c None",
+  ".	c #BEBEBE",
+  "+	c #0000FF",
+  "@	c #FFFFFF",
+  "    ..    ",
+  "  ..+++.  ",
+  " .+++@++. ",
+  " .+++++++ ",
+  " .+++++++ ",
+  ".++@@@++++",
+  ".++++@++++",
+  ".++++@++++",
+  ".++++@++++",
+  " .+++@++++",
+  " .+++@+++ ",
+  " .+@@@@@+ ",
+  " .+++++++ ",
+  "  .+++++  ",
+  "    ++    "
+};
+GdkPixbuf *sb_info_10x15_pixbuf;
+
+/* from  /usr/share/xemacs21/xemacs-packages/etc/xwem/mini-info.xpm */
+/* XPM */
+static const char *mini_info_12x14_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "12 14 3 1",
+/* colors */
+  " 	c None",
+  ".	c #cccc00",
+  "#	c #dddd00",
+/* pixels */
+  "  .#.       ",
+  "  ###       ",
+  "  .#.       ",
+  "            ",
+  "  ...       ",
+  ".###.       ",
+  "..##.       ",
+  " .##.       ",
+  ".###        ",
+  ".##.  .# .# ",
+  ".##.  ######",
+  "###..  #. #.",
+  "####. ####. ",
+  ".#..  .# ##."
+};
+GdkPixbuf *mini_info_12x14_pixbuf;
+
+
+/* from /usr/lib/sourcenav/share/bitmaps/key.xpm */
+/* XPM */
+const static char *key_7x11_xpm[] = {
+/* width height num_colors chars_per_pixel */
+  "7 11 3 1",
+/* colors */
+  " 	c None",
+  ".	c black",
+  "X	c #fefe00",
+/* pixels */
+  " ..... ",
+  ".XXXXX.",
+  ".XX.XX.",
+  ".XXXXX.",
+  " ..XX. ",
+  "  .X.  ",
+  "  .XX. ",
+  "  .X.  ",
+  "  .XX. ",
+  "  .X.  ",
+  "   .   "
+};
+GdkPixbuf *key_7x11_pixbuf;
+
+/* from  /usr/lib/sourcenav/share/bitmaps/tree.xpm */
+/* XPM */
+const static char *tree_24x24_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+  "24 24 7 1 0 0",
+/* colors */
+  " 	s none	m none	c none",
+  ".	s iconColor5	m black	c blue",
+  "X	s iconColor2	m white	c white",
+  "o	s iconColor4	m white	c green",
+  "O	s iconColor1	m black	c black",
+  "+	s iconColor6	m white	c yellow",
+  "@	s iconColor3	m black	c red",
+/* pixels */
+  "                        ",
+  "                 .....  ",
+  "                ..XXX.  ",
+  "         ooooo . .....  ",
+  " OOOOOOOOoXXXo.         ",
+  "         ooooo+         ",
+  "               +        ",
+  "                ++++++  ",
+  "                 +XXX+  ",
+  "                ++++++  ",
+  "         @@@@@ +        ",
+  "        O@XXX@+         ",
+  " OOOOO O @@@@@          ",
+  " OXXXOO                 ",
+  " OOOOO O .....   ooooo  ",
+  "        O.XXX.ooooXXXo  ",
+  "         .....@  ooooo  ",
+  "               @        ",
+  "                @       ",
+  "                 @@@@@  ",
+  "                 @XXX@  ",
+  "                 @@@@@  ",
+  "                        ",
+  "                        "
+};
+GdkPixbuf *tree_24x24_pixbuf;
+
+#ifndef NDEBUG
+FILE *dbgfile;
+#define dbgprintf(Fmt, ...) do{if (dbgfile) { 				\
+      fprintf(dbgfile,"+=simple-probe@%d:" Fmt "\n", (int)__LINE__, ##__VA_ARGS__); \
+      fflush(dbgfile);}}while(0)
+#else
+#define dbgprintf(Fmt, ...) do{}while(0)
+#endif
+
+#define SIMPLE_GTK_TEXTBUFFER(B) GTK_TEXT_BUFFER(B)
+
+GHashTable *action_table;
+
+GtkWidget *window, *vbox, *notebook, *mainlabel, *stabar;
+GtkWidget *menubar, *versionlab, *aboutdialog;
+GtkTextBuffer *tractxtbuf;	/* the textbuffer for trace */
+GtkWidget *tracwindow;		/* trace window */
+GtkWidget *tracbox;		/* trace box */
+GtkWidget *traccheck;		/* check button for scroll following */
+GtkWidget *tracscroll;		/* the scrollbox for trace */
+GtkWidget *tracview;		/* the textview for trace */
+GtkTextTagTable *tractagtbl;	/* tag table for trace */
+GtkTextTag *tractag_tim;	/* tag for time display & requests/commands counters */
+GtkTextTag *tractag_title;	/* tag for title display */
+GtkTextTag *tractag_imp;	/* tag for important display */
+GtkTextTag *tractag_in;		/* tag for input display */
+GtkTextTag *tractag_out;	/* tag for output display */
+
+int trac_followout;		/* flag toggled by traccheck to scroll output */
+
+GtkSourceLanguagesManager *lang_mgr;
+
+struct fileinfo_st
+{
+  int fi_rank;			/* positive index inside fileinfo_array */
+  char *fi_path;		/* strdup-ed file path */
+  GtkWidget *fi_srcview;	/* main source view */
+  GtkSourceBuffer *fi_srcbuf;	/* source buffer */
+};
+GPtrArray *fileinfo_array;
+
+
+struct pointinfo_st
+{
+  int pi_rank;			/* rank of this pointinfo in pointinfo_array */
+  int pi_filenum;		/* file number in fileinfo_array */
+  int pi_line;			/* line number */
+  GtkTextChildAnchor *pi_txanchor;	/* text anchor */
+  GtkWidget *pi_txbutton;	/* button (in text) inside anchor */
+};
+GPtrArray *pointinfo_array;
+
+struct dialogitem_st
+{
+  int di_rank;			/* rank of this item in the dialog menu */
+  struct infodialog_st *di_dialog;	/* owning info dialog */
+};
+
+struct infodialog_st
+{
+  int id_rank;			/* rank of this infodialog in infodialog_array */
+  int id_pinfrank;		/* originating point info rank */
+  GtkWidget *id_dialog;		/* the dialog widget */
+  GtkWidget *id_showcombo;	/* the combo widget to show */
+  GtkWidget *id_menubar;	/* the mavigation menubar inside the widget */
+  GtkWidget *id_infolab;	/* the information label inside the dialog */
+  GPtrArray *id_showitems;	/* array of dialogitem-s for show combo */
+  GPtrArray *id_navitems;	/* array dialogitem-s for navigation */
+  GtkWidget *id_navtitle;	/* the navigation title item in menubar */
+  GtkWidget *id_navmenu;	/* the navigation menu */
+  GtkTooltips *id_tooltips;	/* the dialog tooltips */
+};
+GPtrArray *infodialog_array;
+
+
+guint stid_pass;
+
+typedef void action_handler_t (GString * act, void *data);
+
+struct action_entry_st
+{
+  action_handler_t *handler;
+  void *data;
+};
+
+/* requests are from probe to compiler, single line */
+static void requestprintf (const char *fmt, ...)
+  __attribute__ ((format (printf, 1, 2)));
+
+static void
+register_action (const char *action, action_handler_t * handler, void *data)
+{
+  struct action_entry_st *ae = g_malloc0 (sizeof (struct action_entry_st));
+  ae->handler = handler;
+  ae->data = data;
+  g_assert (action_table != 0);
+  g_hash_table_insert (action_table, g_strdup (action), ae);
+}
+
+/***
+ * decode an encoded string, return the malloc-ed string and fil *PLEN
+ * with its length and *PEND with the ending pointer
+ ***/
+static char *
+decode_string (const char *s, int *plen, char **pend)
+{
+  char *res = 0;
+  int len = 0, pos = 0, ix = 0;
+  if (!s)
+    return (char *) 0;
+  if (sscanf (s, " STR%d'%n", &len, &pos) > 0 && pos > 0)
+    {
+      res = g_malloc0 (len + 1);
+      s += pos;
+      for (ix = 0; ix < len; ix++)
+	{
+	  char c = *s;
+	  if (c == '%')
+	    {
+	      int d = 0;
+	      char c1, c2;
+	      if ((c1 = s[1]) && isxdigit (c1)
+		  && (c2 = s[2]) && isxdigit (c2))
+		{
+		  d = (((c1 >= '0' && c1 <= '9') ? (c1 - '0')
+			: (c1 >= 'A' && c1 <= 'F') ? (10 + c1 - 'A')
+			: (c1 >= 'a' && c1 <= 'f') ? (10 + c1 - 'a')
+			: 0) << 4)
+		    + ((c2 >= '0' && c2 <= '9') ? (c2 - '0')
+		       : (c2 >= 'A' && c2 <= 'F') ? (10 + c2 - 'A')
+		       : (c2 >= 'a' && c2 <= 'f') ? (10 + c2 - 'a') : 0);
+		  res[ix] = (char) d;
+		  s += 3;
+		}
+	      else
+		goto error;
+	    }
+	  else if (c == '+')
+	    {
+	      res[ix] = ' ';
+	      s++;
+	    }
+	  else if (c > ' ' && c != '\'' && c != '\"')
+	    {
+	      res[ix] = c;
+	      s++;
+	    }
+	  else
+	    goto error;
+	};
+      if (*s != '\'')
+	goto error;
+      s++;
+      if (plen)
+	*plen = len;
+      if (pend)
+	*pend = (char *) s;
+      return res;
+    }
+error:
+  if (res)
+    g_free (res);
+  return 0;
+}
+
+
+/*** follow the trace window by scrolling to end ***/
+void
+trac_follow_end ()
+{
+  if (trac_followout && tracview)
+    {
+      GtkTextIter titer;
+      gtk_text_buffer_get_end_iter (tractxtbuf, &titer);
+      gtk_text_view_scroll_to_iter (GTK_TEXT_VIEW (tracview), &titer,
+				    /*margin */ 0.05,
+				    /*usalign */ FALSE,
+				    /*xalign */ 0.0,
+				    /* yalign */ 0.9);
+    }
+}
+
+gboolean
+delayed_follow_end_oncecb (gpointer data)
+{
+  g_assert (data == NULL);
+  trac_follow_end ();
+  if (tractxtbuf && tracview)
+    gtk_widget_show (tracview);
+  return FALSE;			/* remove this idle callback immediately */
+}
+
+/**************************** actions **************************/
+
+
+static void
+message_act (GString * s, void *d)
+{
+  char *msg = 0, *end = 0;
+  int pos = 0, len = 0;
+  g_assert (d != s);		/* just to use the arguments */
+  dbgprintf ("message action %s", s->str);
+  if (sscanf (s->str, " PROB_message msg: %n", &pos) >= 0 && pos > 0)
+    msg = decode_string (s->str + pos, &len, &end);
+  if (msg)
+    {
+      gtk_statusbar_pop (GTK_STATUSBAR (stabar), stid_pass);
+      gtk_statusbar_push (GTK_STATUSBAR (stabar), stid_pass, msg);
+      gtk_widget_show (stabar);
+      g_free (msg);
+    }
+  else
+    dbgprintf ("invalid message action %s", s->str);
+}
+
+static void
+version_act (GString * s, void *d)
+{
+  char *msg = 0, *markup = 0, *end = 0;
+  int pos = -1, len = 0, protonum = 0;
+  g_assert (d != s);		/* just to use the arguments */
+  dbgprintf ("version action %s", s->str);
+  if (sscanf (s->str, " PROB_version proto: %d msg:%n", &protonum, &pos) >= 0
+      && pos > 0) 
+    msg = decode_string (s->str + pos, &len, &end);
+  if (protonum != PROBE_PROTOCOL_NUMBER)
+    {
+      dbgprintf ("invalid protocol number %d expecting %d", protonum,
+		 PROBE_PROTOCOL_NUMBER);
+      exit (1);
+    }
+  if (msg)
+    {
+      markup =
+	g_markup_printf_escaped
+	("<small>(protocol %d)</small> - GCC "
+	 "<span style='italic' foreground='darkgreen'>" "%s" "</span>",
+	 protonum, msg);
+      gtk_label_set_markup (GTK_LABEL (versionlab), markup);
+      gtk_widget_show_all (window);
+      g_free (markup);
+    }
+  else
+    dbgprintf ("invalid version action (pos%d protonum%d no msg): %s",
+	       pos, protonum, s->str);
+  
+}
+
+
+static void
+file_act (GString * s, void *d)
+{
+  int filerank = -1, pos = -1, len = 0;
+  int fd = -1;
+  char *file_path = 0, *end = 0;
+  gchar *basename = 0;
+  gchar *mime_type = 0;
+  char *suffix = 0, *markup = 0;
+  GtkSourceLanguage *language = NULL;
+  GtkSourceBuffer *srcbuf = NULL;
+  GtkWidget *srcview = NULL;
+  GtkWidget *scrolwin = NULL;
+  GtkWidget *label = NULL;
+  GtkWidget *tablab = NULL;
+  GtkWidget *box = NULL;
+  struct stat filestat;
+  struct fileinfo_st *filinf = NULL;
+  const gchar *fcontent = 0;
+  size_t filesize = 0;
+  size_t mapsize = 0;
+  static size_t pgsiz;
+  g_assert (d != s);		/* just to use the arguments */
+  memset (&filestat, 0, sizeof (filestat));
+  if (sscanf (s->str, " PROB_file rank: %d fpath: %n", &filerank, &pos)
+      > 0 && filerank >= 0 && pos > 0)
+    {
+      file_path = decode_string (s->str + pos, &len, &end);
+      if ((fd = open (file_path, O_RDONLY)) < 0)
+	{
+	  dbgprintf ("failed to open %s : %m", file_path);
+	  return;
+	}
+      basename = g_path_get_basename ((const gchar *) file_path);
+      suffix = g_strrstr (basename, (const gchar *) ".");
+      if (!strcmp (suffix, ".cc")
+	  || !strcmp (suffix, ".cxx")
+	  || !strcmp (suffix, ".cpp")
+	  || !strcmp (suffix, ".cp")
+	  || !strcmp (suffix, ".ii")
+	  || !strcmp (suffix, ".CPP")
+	  || !strcmp (suffix, ".hh")
+	  || !strcmp (suffix, ".hxx")
+	  || !strcmp (suffix, ".hpp")
+	  || !strcmp (suffix, ".C") || !strcmp (suffix, ".H"))
+	mime_type = "text/x-c++src";
+      else if (!strcmp (suffix, ".c")
+	       || !strcmp (suffix, ".i") || !strcmp (suffix, ".h"))
+	mime_type = "text/x-csrc";
+      else if (!strcmp (suffix, ".f")
+	       || !strcmp (suffix, ".F")
+	       || !strcmp (suffix, ".FOR")
+	       || !strcmp (suffix, ".F77")
+	       || !strcmp (suffix, ".f77")
+	       || !strcmp (suffix, ".F95")
+	       || !strcmp (suffix, ".f95")
+	       || !strcmp (suffix, ".F90")
+	       || !strcmp (suffix, ".f90") || !strcmp (suffix, ".for"))
+	mime_type = "text/x-fortran";
+      else if (!strcmp (suffix, ".adb")
+	       || !strcmp (suffix, ".ads") || !strcmp (suffix, ".ada"))
+	mime_type = "text/x-ada";
+      if (!mime_type)
+	mime_type = "text/x-c++src";
+      dbgprintf ("file %s mimetype %s", file_path, mime_type);
+      if (!fstat (fd, &filestat))
+	filesize = filestat.st_size;
+      language =
+	gtk_source_languages_manager_get_language_from_mime_type (lang_mgr,
+								  mime_type);
+      g_assert (language != NULL);
+      srcbuf = gtk_source_buffer_new_with_language (language);
+      srcview = gtk_source_view_new_with_buffer (srcbuf);
+      g_object_set (G_OBJECT (srcview), "editable", FALSE, NULL);
+      gtk_source_buffer_set_highlight (srcbuf, TRUE);
+      gtk_source_buffer_begin_not_undoable_action (srcbuf);
+      if (!pgsiz)
+	pgsiz = getpagesize ();
+      if (filesize > (off_t) 0)
+	{
+	  gchar *convcont = 0;
+	  gsize convsize = 0;
+	  mapsize = filesize;
+	  if (mapsize % pgsiz)
+	    mapsize = (filesize | (pgsiz - 1)) + 1;
+	  fcontent = (const gchar *) mmap ((void *) 0, mapsize, PROT_READ,
+					   MAP_SHARED, fd, (off_t) 0);
+	  if (fcontent != MAP_FAILED)
+	    {
+	      convcont =
+		g_locale_to_utf8 (fcontent, filesize, NULL, &convsize,
+				  (GError **) 0);
+	      g_assert (convcont);
+	      if (convcont)
+		gtk_text_buffer_set_text (SIMPLE_GTK_TEXTBUFFER (srcbuf),
+					  convcont, convsize);
+	      g_free (convcont);
+	      munmap ((char *) fcontent, mapsize);
+	      fcontent = 0;
+	    }
+	  else
+	    fprintf (stderr, "mmap file %s size %ld failed: %m\n",
+		     file_path, filesize);
+	};
+      close (fd);
+      gtk_source_buffer_end_not_undoable_action (srcbuf);
+      gtk_source_view_set_show_line_numbers (GTK_SOURCE_VIEW (srcview), TRUE);
+      gtk_source_view_set_show_line_markers (GTK_SOURCE_VIEW (srcview), TRUE);
+      markup = g_markup_printf_escaped
+	("<span weight=\"bold\" size=\"larger\">%d</span>\n"
+	 "<small><tt>%s</tt></small>", filerank, basename);
+      tablab = gtk_label_new ((char *) 0);
+      gtk_label_set_markup (GTK_LABEL (tablab), markup);
+      g_free (markup);
+      label = gtk_label_new ((char *) 0);
+      markup = g_markup_printf_escaped
+	("<span weight=\"bold\" size=\"larger\">#%d</span>\n"
+	 "<span color='navy' style='italic'>file "
+	 "<small><tt>%s</tt></small>\n"
+	 "of %ld bytes</span>", filerank, file_path, (long) filesize);
+      gtk_label_set_markup (GTK_LABEL (label), markup);
+      g_free (markup);
+      g_free (basename);
+      basename = suffix = markup = NULL;
+      scrolwin = gtk_scrolled_window_new (NULL, NULL);
+      gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (scrolwin),
+				      GTK_POLICY_NEVER, GTK_POLICY_AUTOMATIC);
+      gtk_container_add (GTK_CONTAINER (scrolwin), srcview);
+      box = gtk_vbox_new (FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (box), label, FALSE, FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (box), scrolwin, TRUE, TRUE, 1);
+      gtk_notebook_insert_page (GTK_NOTEBOOK (notebook), box, tablab,
+				(gint) filerank);
+      if (fileinfo_array->len <= filerank)
+	g_ptr_array_set_size (fileinfo_array, 5 * filerank / 4 + 16);
+      filinf = g_malloc0 (sizeof (*filinf));
+      g_assert (g_ptr_array_index (fileinfo_array, filerank) == NULL);
+      g_ptr_array_index (fileinfo_array, filerank) = filinf;
+      filinf->fi_rank = filerank;
+      filinf->fi_path = g_strdup (file_path);
+      filinf->fi_srcview = srcview;
+      filinf->fi_srcbuf = srcbuf;
+      gtk_source_view_set_marker_pixbuf (GTK_SOURCE_VIEW (srcview), "info",
+					 sb_info_10x15_pixbuf);
+      gtk_widget_show_all (window);
+      g_free (file_path);
+    }
+}
+
+/* GTK callback called when an info dialog is responded */
+static void
+infodialog_cb (GtkWidget * widget, int respid, gpointer data)
+{
+  struct infodialog_st *dia = data;
+  g_assert (dia && dia->id_dialog == widget);
+  switch (respid)
+    {
+    case GTK_RESPONSE_ACCEPT:
+      requestprintf ("prob_UPDATEINFODIALOG dia:%d\n", dia->id_rank);
+      break;
+    case GTK_RESPONSE_CLOSE:
+    default:
+      requestprintf ("prob_REMOVEINFODIALOG dia:%d\n", dia->id_rank);
+      gtk_widget_hide (dia->id_dialog);
+      break;
+    }
+}
+
+/* internal routine to create a new info dialog (still empty and not
+   displayed) */
+static struct infodialog_st *
+make_infodialog (struct pointinfo_st *pi)
+{
+  int ix = 0, k;
+  struct infodialog_st *dia = NULL;
+  struct fileinfo_st *fi = NULL;
+  GtkWidget *dialog = NULL, *hbox = NULL, *menubar = NULL, *combo = NULL,
+    *showlabel = NULL, *pointlabel = NULL, *infolabel = NULL,
+    *infoscroll = NULL;
+  GtkTooltips *tooltips = NULL;
+  char titbuf[64];
+  char *pointmarkup = 0;
+  g_assert (pi != NULL && pi->pi_rank >= 0
+	    && pi->pi_rank < pointinfo_array->len);
+  g_assert (g_ptr_array_index (pointinfo_array, pi->pi_rank) == pi);
+  g_assert (pi->pi_filenum >= 0 && fileinfo_array
+	    && pi->pi_filenum < fileinfo_array->len);
+  fi = g_ptr_array_index (fileinfo_array, pi->pi_filenum);
+  dia = g_malloc0 (sizeof (*dia));
+  memset (titbuf, 0, sizeof (titbuf));
+  ix = -1;
+  if (infodialog_array)
+    {
+      for (k = 0; k < infodialog_array->len; k++)
+	if (!g_ptr_array_index (infodialog_array, k))
+	  {
+	    ix = k;
+	    break;
+	  }
+    }
+  if (ix >= 0)
+    {
+      dia->id_rank = ix;
+      g_ptr_array_index (infodialog_array, ix) = dia;
+    }
+  else
+    {
+      dia->id_rank = infodialog_array->len;
+      g_ptr_array_add (infodialog_array, dia);
+    }
+  dbgprintf ("make_infodialog dia %p rank %d", dia, dia->id_rank);
+  dia->id_pinfrank = pi->pi_rank;
+  snprintf (titbuf, sizeof (titbuf) - 1, "InfoPt#%d", dia->id_rank);
+  dialog = dia->id_dialog
+    = gtk_dialog_new_with_buttons
+    (titbuf,
+     GTK_WINDOW (window),
+     GTK_DIALOG_DESTROY_WITH_PARENT,
+     GTK_STOCK_HOME, GTK_RESPONSE_ACCEPT,
+     GTK_STOCK_CLOSE, GTK_RESPONSE_CLOSE, NULL);
+  tooltips = dia->id_tooltips = gtk_tooltips_new ();
+  pointlabel = gtk_label_new ((char *) 0);
+  pointmarkup = g_markup_printf_escaped
+    ("<span size='large' foreground='darkgreen'>"
+     "info point #%d" "</span>\n"
+     "<b>file #%d</b> <tt>%s</tt> <i>line %d</i>",
+     dia->id_rank, pi->pi_filenum, fi->fi_path, pi->pi_line);
+  gtk_label_set_markup (GTK_LABEL (pointlabel), pointmarkup);
+  g_free (pointmarkup);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      pointlabel, /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  hbox = gtk_hbox_new (FALSE, 3);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      hbox, /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  showlabel = gtk_label_new ((char *) 0);
+  gtk_label_set_markup (GTK_LABEL (showlabel),
+			"<span foreground='navy' weight='bold'>"
+			"show:" "</span>");
+  gtk_box_pack_start (GTK_BOX (hbox), showlabel,
+		      /*expand: */ FALSE, /*fill: */ FALSE,
+		      1);
+  combo = dia->id_showcombo = gtk_combo_box_new_text ();
+  gtk_tooltips_set_tip (tooltips, combo,
+			"Select information to show",
+			"Choose the information to show in this dialog\n"
+			"for this info point");
+  gtk_box_pack_start (GTK_BOX (hbox), combo,
+		      /*expand: */ TRUE, /*fill: */ TRUE,
+		      1);
+  menubar = dia->id_menubar = gtk_menu_bar_new ();
+  gtk_tooltips_set_tip (tooltips, menubar,
+			"Navigation menu",
+			"Choose where to go in this dialog\n"
+			"for this info point");
+  gtk_box_pack_start (GTK_BOX (hbox), menubar,
+		      /*expand: */ FALSE, /*fill: */ FALSE,
+		      2);
+  infoscroll = gtk_scrolled_window_new (NULL, NULL);
+  gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (infoscroll),
+				  GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
+  dia->id_infolab = infolabel = gtk_label_new ((char *) 0);
+  gtk_label_set_markup (GTK_LABEL (infolabel),
+			"<span size='large' foreground='darkred'>"
+			"* select info to show *" "</span>\n");
+  gtk_label_set_selectable (GTK_LABEL (infolabel), TRUE);
+  gtk_scrolled_window_add_with_viewport (GTK_SCROLLED_WINDOW (infoscroll),
+					 infolabel);
+  gtk_box_pack_start (GTK_BOX (GTK_DIALOG (dialog)->vbox),
+		      infoscroll, /*expand: */ TRUE, /*fill: */ TRUE, 1);
+  dia->id_showitems = g_ptr_array_sized_new (6);
+  g_signal_connect (G_OBJECT (dialog),
+		    "response", G_CALLBACK (infodialog_cb), dia);
+  dbgprintf ("make_infodialog dia %p rank %d", dia, dia->id_rank);
+  return dia;
+}
+
+
+/* GTK callback called when an info button is clicked; should create a
+   dialog and ask it to be filled */
+static void
+txinfobutton_cb (GtkWidget * widget, gpointer data)
+{
+  struct pointinfo_st *pi = data;
+  struct infodialog_st *dia = NULL;
+  g_assert (pi && pi->pi_txbutton == widget);
+  dia = make_infodialog (pi);
+  requestprintf ("prob_NEWINFODIALOG pt:%d dia:%d\n",
+		 pi->pi_rank, dia->id_rank);
+}
+
+
+/* GTK callback called when about information has been asked */
+static void
+aboutwin_cb (GtkWidget * widget, gpointer data)
+{
+  if (!aboutdialog)
+    {
+      aboutdialog = gtk_about_dialog_new ();
+      gtk_about_dialog_set_name (GTK_ABOUT_DIALOG (aboutdialog),
+				 "GCC simple compiler probe");
+      gtk_about_dialog_set_copyright (GTK_ABOUT_DIALOG (aboutdialog),
+				      "Copyright (C) 2007 Free Software Foundation, Inc");
+      gtk_about_dialog_set_license (GTK_ABOUT_DIALOG (aboutdialog),
+				    "GNU General Public License version 2 or later");
+      gtk_about_dialog_set_website (GTK_ABOUT_DIALOG (aboutdialog),
+				    "http://gcc.gnu.org/");
+      gtk_about_dialog_set_comments (GTK_ABOUT_DIALOG (aboutdialog),
+				     "A simple compiler probe to be used with GCC\n"
+				     " [Gnu Compiler Collection] \n"
+				     "with its -fcompiler-probe option\n"
+				     "(simple-probe built " __DATE__ "@"
+				     __TIME__ ")");
+    };
+  gtk_dialog_run (GTK_DIALOG (aboutdialog));
+}
+
+
+static void
+infopoint_act (GString * s, void *d)
+{
+  int filerk = 0;
+  int lineno = 0;
+  int infonum = 0;
+  struct fileinfo_st *filinf = NULL;
+  struct pointinfo_st *pi = NULL;
+  char *filepath = NULL;
+  GtkTextIter txiter;
+  GtkSourceBuffer *srcbuf = NULL;
+  GtkWidget *srcview = NULL;
+  GtkWidget *txbutton = NULL;
+  GtkTextChildAnchor *anch = NULL;
+  g_assert (s != d);
+  if (sscanf
+      (s->str, " PROB_infopoint fil:%d lin:%d rk:%d", &filerk, &lineno,
+       &infonum) > 0 && infonum >= 0)
+    {
+      dbgprintf ("infopoint act filerk %d lineno %d infonum %d",
+		 filerk, lineno, infonum);
+      memset (&txiter, 0, sizeof (txiter));
+      if (filerk >= 0 && filerk < fileinfo_array->len)
+	filinf = g_ptr_array_index (fileinfo_array, filerk);
+      if (!filinf)
+	return;
+      if (pointinfo_array->len <= infonum)
+	g_ptr_array_set_size (pointinfo_array, 5 * infonum / 4 + 16);
+      if (g_ptr_array_index (pointinfo_array, infonum) != NULL)
+	return;
+      filepath = filinf->fi_path;
+      g_assert (filepath);
+      srcbuf = filinf->fi_srcbuf;
+      srcview = filinf->fi_srcview;
+      g_assert (srcbuf);
+      pi = g_malloc0 (sizeof (struct pointinfo_st));
+      g_ptr_array_index (pointinfo_array, infonum) = pi;
+      pi->pi_rank = infonum;
+      pi->pi_filenum = filerk;
+      pi->pi_line = lineno;
+      gtk_text_buffer_get_iter_at_line (GTK_TEXT_BUFFER (srcbuf), &txiter,
+					lineno - 1);
+      anch =
+	gtk_text_buffer_create_child_anchor (GTK_TEXT_BUFFER (srcbuf),
+					     &txiter);
+      txbutton = gtk_button_new ();
+      gtk_button_set_image (GTK_BUTTON (txbutton),
+			    gtk_image_new_from_pixbuf (key_7x11_pixbuf));
+      gtk_text_view_add_child_at_anchor (GTK_TEXT_VIEW (srcview), txbutton,
+					 anch);
+      gtk_widget_show_all (txbutton);
+      gtk_widget_show_all (srcview);
+      gtk_widget_show_all (window);
+      pi->pi_txanchor = anch;
+      pi->pi_txbutton = txbutton;
+      g_signal_connect (G_OBJECT (txbutton), "clicked",
+			G_CALLBACK (txinfobutton_cb), pi);
+    }
+  else
+    dbgprintf ("invalid infopoint_act %s", s->str);
+}
+
+/* GTK callback of show items */
+static void
+showcombochanged_cb (GtkComboBox * combo, struct infodialog_st *dia)
+{
+  gint rk = -1;
+  g_assert (combo && dia && dia->id_showcombo == GTK_WIDGET (combo));
+  rk = gtk_combo_box_get_active (combo);
+  if (rk >= 0)
+    requestprintf ("prob_SHOWINFODIALOG dia:%d ch:%d\n", dia->id_rank, rk);
+}
+
+static void
+dialogchoice_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1, len = 0, chrk = -1;
+  char *end = 0, *msg = 0;
+  struct infodialog_st *dia = NULL;
+  struct dialogitem_st *itm = NULL;
+  g_assert (s != d);
+  dbgprintf ("dialogchoice_act start %s", s->str);
+  if (sscanf
+      (s->str, " PROB_dialogchoice dia: %d msg: %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialogchoice_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("dialogchoice_act dia %p", dia);
+      msg = decode_string (s->str + pos, &len, &end);
+      if (sscanf (end, " ch: %d", &chrk) <= 0 || chrk < 0)
+	{
+	  g_free (msg);
+	  return;
+	}
+      itm = g_malloc0 (sizeof (*itm));
+      itm->di_rank = chrk;
+      itm->di_dialog = dia;
+      g_ptr_array_add (dia->id_showitems, itm);
+      gtk_combo_box_insert_text (GTK_COMBO_BOX (dia->id_showcombo), chrk,
+				 msg);
+      g_signal_connect (G_OBJECT (dia->id_showcombo), "changed",
+			G_CALLBACK (showcombochanged_cb), (gpointer) dia);
+      g_free (msg);
+      dbgprintf ("dialogchoice_act done dia %p", dia);
+    }
+}
+
+
+static void
+dialogcontent_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1;
+  struct infodialog_st *dia = NULL;
+  char *ps = 0;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_dialogcontent dia: %d %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialogcontent_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      ps = s->str + pos;
+      dbgprintf ("dialogcontent_act dia %p", dia);
+      gtk_label_set_text (GTK_LABEL (dia->id_infolab), ps);
+      /* destroy the navigation items & menu */
+      if (dia->id_navitems)
+	{
+	  g_ptr_array_free (dia->id_navitems, TRUE);
+	  dia->id_navitems = NULL;
+	}
+      if (dia->id_navmenu)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navmenu));
+	  dia->id_navmenu = NULL;
+	}
+      if (dia->id_navtitle)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navtitle));
+	  dia->id_navtitle = NULL;
+	}
+    }
+}
+
+static void
+showdialog_act (GString * s, void *d)
+{
+  int diark = -1;
+  struct infodialog_st *dia = NULL;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_showdialog dia:%d", &diark) > 0 && diark >= 0)
+    {
+      dbgprintf ("showdialog_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("showdialog_act dia %p", dia);
+      gtk_widget_show_all (dia->id_dialog);
+    }
+}
+
+
+/*GTK callback for dialog navigation items */
+static void
+navigitem_cb (GtkMenuItem * menuitem, gpointer data)
+{
+  struct dialogitem_st *itm = data;
+  g_assert (itm != 0 && itm->di_dialog);
+  requestprintf ("prob_NAVIGINFODIALOG dia:%d nav:%d\n",
+		 itm->di_dialog->id_rank, itm->di_rank);
+
+}
+
+
+static void
+dialognavig_act (GString * s, void *d)
+{
+  int diark = -1, pos = -1, len = 0, navrk = -1;
+  char *end = 0, *msg = 0;
+  struct infodialog_st *dia = NULL;
+  struct dialogitem_st *itm = NULL;
+  GtkWidget *menuitem = NULL, *sepitem = NULL, *navigitem = NULL;
+  g_assert (s != d);
+  dbgprintf ("dialognavig_act start %s", s->str);
+  if (sscanf
+      (s->str, " PROB_dialognavig dia: %d msg: %n", &diark, &pos) > 0
+      && diark >= 0 && pos > 0)
+    {
+      dbgprintf ("dialognavig_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("dialognavig_act dia %p", dia);
+      msg = decode_string (s->str + pos, &len, &end);
+      if (sscanf (end, " nav: %d", &navrk) <= 0 || navrk < 0)
+	{
+	  dbgprintf ("dialognavig_act bad end %s", end);
+	  g_free (msg);
+	  return;
+	}
+      itm = g_malloc0 (sizeof (*itm));
+      dbgprintf ("dialognavig_act navrk %d msg %s", navrk, msg);
+      itm->di_rank = navrk;
+      itm->di_dialog = dia;
+      if (!dia->id_navitems)
+	dia->id_navitems = g_ptr_array_sized_new (6);
+      g_ptr_array_add (dia->id_navitems, itm);
+      menuitem = gtk_menu_item_new_with_label (msg);
+      if (!dia->id_navmenu)
+	{
+	  dia->id_navmenu = gtk_menu_new ();
+	  dbgprintf ("dialognavig_act navmenu %p", dia->id_navmenu);
+	  sepitem = gtk_separator_menu_item_new ();
+	  gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_navmenu), sepitem);
+	  g_assert (GTK_IS_MENU_SHELL (dia->id_menubar));
+	  navigitem = dia->id_navtitle =
+	    gtk_menu_item_new_with_label ("navigation");
+	  gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_menubar), navigitem);
+	  gtk_menu_item_set_submenu (GTK_MENU_ITEM (navigitem),
+				     dia->id_navmenu);
+	  gtk_widget_show (dia->id_navmenu);
+	}
+      gtk_menu_shell_append (GTK_MENU_SHELL (dia->id_navmenu), menuitem);
+      gtk_widget_show (menuitem);
+      g_free (msg);
+      msg = NULL;
+      g_signal_connect (G_OBJECT (menuitem),
+			"activate", G_CALLBACK (navigitem_cb), itm);
+      dbgprintf ("dialognavig_act done dia %p", dia);
+    }
+}
+
+
+static void
+destroydialog_act (GString * s, void *d)
+{
+  int diark = -1;
+  struct infodialog_st *dia = NULL;
+  g_assert (s != d);
+  if (sscanf (s->str, " PROB_destroydialog dia: %d", &diark) > 0
+      && diark >= 0)
+    {
+      dbgprintf ("destroydialog_act diark%d", diark);
+      if (!infodialog_array || diark >= infodialog_array->len)
+	return;
+      dia = g_ptr_array_index (infodialog_array, diark);
+      if (!dia || dia->id_rank != diark)
+	return;
+      dbgprintf ("destroydialog_act dia %p", dia);
+      if (dia->id_dialog)
+	gtk_widget_hide (dia->id_dialog);
+      if (dia->id_navitems)
+	{
+	  g_ptr_array_free (dia->id_navitems, TRUE);
+	  dia->id_navitems = NULL;
+	}
+      if (dia->id_navmenu)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navmenu));
+	  dia->id_navmenu = NULL;
+	}
+      if (dia->id_navtitle)
+	{
+	  gtk_object_destroy (GTK_OBJECT (dia->id_navtitle));
+	  dia->id_navtitle = NULL;
+	}
+      gtk_object_destroy (GTK_OBJECT (dia->id_dialog));
+      g_ptr_array_free (dia->id_showitems, TRUE);
+      memset (dia, 0, sizeof (dia));
+      g_ptr_array_index (infodialog_array, diark) = NULL;
+      g_free (dia);
+      dbgprintf ("destroydialog_act done diark%d", diark);
+    }
+}
+
+/*********************** request & trace ***********************/
+static void
+insert_trace_time (int dated, const char *buf)
+{
+  struct
+  {
+    char buf[200];
+    GTimeVal tv;
+    struct tm tm;
+    char sec[10];
+  } t;
+  time_t tim;
+  GtkTextIter itend;
+  memset (&t, 0, sizeof (t));
+  memset (&itend, 0, sizeof (itend));
+  g_get_current_time (&t.tv);
+  tim = t.tv.tv_sec;
+  localtime_r (&tim, &t.tm);
+  strftime (t.buf, sizeof (t.buf) - 10, dated ? " %G %b %d @ %T" : " %T",
+	    &t.tm);
+  sprintf (t.sec, ".%03d ", (int) t.tv.tv_usec / 1000);
+  strcat (t.buf, t.sec);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, "\n", -1,
+				    tractag_tim, (void *) 0);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  if (buf)
+    gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, buf, -1,
+				      tractag_tim, (void *) 0);
+  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf), &itend);
+  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, t.buf, -1,
+				    tractag_tim, (void *) 0);
+}
+
+
+static void
+requestprintf (const char *fmt, ...)
+{
+  va_list ar;
+  gchar *buf = 0;
+  gint len = 0;
+  static int nbreq;
+  GtkTextIter itend;
+  char bufn[64];
+  va_start (ar, fmt);
+  nbreq++;
+  len = g_vasprintf (&buf, (const gchar *) fmt, ar);
+  va_end (ar);
+  dbgprintf ("begin requestprintf %.30s", fmt);
+  if (tractxtbuf)
+    {
+      memset (&itend, 0, sizeof (itend));
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      memset (bufn, 0, sizeof (bufn));
+      snprintf (bufn, sizeof (bufn) - 1, "!request %d:", nbreq);
+      insert_trace_time (0, bufn);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, buf, len,
+					tractag_out, (void *) 0);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+    };
+  fputs (buf, stdout);
+  if (len <= 0 || buf[len - 1] != '\n')
+    {
+      putchar ('\n');
+      if (tractxtbuf)
+	gtk_text_buffer_insert (tractxtbuf, &itend, "\n", 1);
+    };
+  fflush (stdout);
+  if (tractxtbuf)
+    {
+      trac_follow_end ();
+      gtk_widget_show_all (tracwindow);
+    }
+  dbgprintf ("request #%d: %s\n", nbreq, buf);
+  g_free (buf);
+  if (tractxtbuf && trac_followout)
+    g_idle_add (delayed_follow_end_oncecb, (void *) 0);
+  buf = 0;
+}
+
+static gboolean
+ioreader (GIOChannel * chan, GIOCondition cond, gpointer data)
+{
+  gchar *end = 0, *line = 0;
+  gsize len = 0;
+  gsize eolpos = 0;
+  GIOStatus stat = 0;
+  GError *err = 0;
+  GString *str = 0;
+  int leftmagic = 0, rightmagic = 0, pos = 0;
+  char verb[64];
+  char bufn[48];
+  static int nbcmd;
+  g_assert (cond == G_IO_IN);
+  line = end = 0;
+  len = eolpos = 0;
+  dbgprintf ("ioreader begin");
+  stat = g_io_channel_read_line (chan, &line, &len, &eolpos, &err);
+  dbgprintf ("ioreader stat %d", stat);
+  if (stat == G_IO_STATUS_NORMAL)
+    {
+      if (line[0] == '!'
+	  && sscanf (line, "!#%x/%X[%n", &leftmagic, &rightmagic, &pos) >= 2
+	  && rightmagic != 0 && pos > 0)
+	{			/* multi-line command */
+	  str = g_string_sized_new (1000 + eolpos);
+	  str = g_string_append (str, line + pos);
+	  g_free (line);
+	  line = 0;
+	  while ((stat =
+		  g_io_channel_read_line (chan, &line, &len, &eolpos,
+					  &err)) == G_IO_STATUS_NORMAL)
+	    {
+	      int left, right;
+	      left = right = pos = 0;
+	      if (line[0] == '!'
+		  && sscanf (line, "!#%x/%X] %n", &left, &right, &pos) >= 2
+		  && pos > 0 && left == leftmagic && right == rightmagic
+		  && line[pos] == '\0')
+		{
+		  g_free (line);
+		  line = 0;
+		  break;
+		};
+	      str = g_string_append (str, line);
+	      g_free (line);
+	      line = 0;
+
+	    };
+	}
+      else
+	{			/* ordinary single line command */
+	  str = g_string_sized_new (1000 + eolpos);
+	  str = g_string_append (str, line);
+	  g_free (line);
+	  line = 0;
+	}
+    }
+  if (str && str->len == 1 && str->str[0] == '\n')
+    return TRUE;
+  nbcmd++;
+  dbgprintf ("command #%d: %s\n", nbcmd, str->str);
+  if (tractxtbuf)
+    {
+      GtkTextIter itend;
+      memset (&itend, 0, sizeof (itend));
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      memset (bufn, 0, sizeof (bufn));
+      snprintf (bufn, sizeof (bufn) - 1, "?command %d:", nbcmd);
+      insert_trace_time (0, bufn);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      gtk_text_buffer_insert_with_tags (tractxtbuf, &itend, str->str,
+					str->len, tractag_in, (void *) 0);
+      gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+				    &itend);
+      if (str->len > 0 && str->str[str->len - 1] != '\n')
+	gtk_text_buffer_insert (tractxtbuf, &itend, "\n", 1);
+      trac_follow_end ();
+    };
+  memset (verb, 0, sizeof (verb));
+  if (str && sscanf (str->str, " %62[a-zA-Z0-9_] ", verb) > 0)
+    {
+      struct action_entry_st *ae = g_hash_table_lookup (action_table, verb);
+      dbgprintf ("command verb %s", verb);
+      if (ae && ae->handler)
+	{
+	  (*ae->handler) (str, ae->data);
+	  if (tractxtbuf)
+	    trac_follow_end ();
+	}
+      else if (tractxtbuf)
+	{
+	  static char unknownmsg[200];
+	  GtkTextIter itend;
+	  memset (&itend, 0, sizeof (itend));
+	  gtk_text_buffer_get_end_iter (SIMPLE_GTK_TEXTBUFFER (tractxtbuf),
+					&itend);
+	  memset (unknownmsg, 0, sizeof (unknownmsg));
+	  snprintf (unknownmsg, sizeof (unknownmsg) - 1,
+		    "*?* unknown command verb '%s'\n", verb);
+	  dbgprintf ("*? unknown command verb '%s'", verb);
+	  gtk_text_buffer_insert_with_tags (tractxtbuf, &itend,
+					    unknownmsg, strlen (unknownmsg),
+					    tractag_tim, (void *) 0);
+	  trac_follow_end ();
+	}
+      if (tractxtbuf)
+	gtk_widget_show_all (tracwindow);
+    }
+  else
+    dbgprintf ("invalid command string %s", str->str);
+  if (str)
+    g_string_free (str, TRUE);
+  if (tractxtbuf && trac_followout)
+    g_idle_add (delayed_follow_end_oncecb, (void *) 0);
+  str = 0;
+  /* remove the handler on eof */
+  dbgprintf ("stat=%d isnormal=%d", stat, stat != G_IO_STATUS_EOF);
+  /* the function should return FALSE if the event source should be removed. */
+  return stat != G_IO_STATUS_EOF;
+}
+
+static void
+destroy_cb (GtkWidget * widget, gpointer data)
+{
+  requestprintf ("prob_STOP\n");
+  gtk_main_quit ();
+}
+
+static void
+tracdestroy_cb (GtkWidget * widget, gpointer data)
+{
+  g_assert (widget == tracwindow);
+  tracwindow = (void *) 0;
+  tracbox = (void *) 0;
+  tracscroll = (void *) 0;
+  tracview = (void *) 0;
+  tractagtbl = (void *) 0;
+  tractag_tim = tractag_title = tractag_imp = tractag_in = tractag_out = 0;
+  tractxtbuf = 0;
+}
+
+
+static GtkItemFactoryEntry menu_items[] = {
+  {"/_File", NULL, NULL, 0, "<Branch>"},
+  {"/File/_Quit", "<CTRL>Q", gtk_main_quit, 0, "<StockItem>", GTK_STOCK_QUIT},
+  {"/_Help", NULL, NULL, 0, "<LastBranch>"},
+  {"/_Help/About", NULL, aboutwin_cb, 0, "<Item>"},
+};
+
+/* Returns a menubar widget made from the above menu */
+static GtkWidget *
+get_menubar_menu (GtkWidget * window)
+{
+  GtkItemFactory *item_factory;
+  GtkAccelGroup *accel_group;
+
+  /* Make an accelerator group (shortcut keys) */
+  accel_group = gtk_accel_group_new ();
+
+  /* Make an ItemFactory (that makes a menubar) */
+  item_factory = gtk_item_factory_new (GTK_TYPE_MENU_BAR, "<main>",
+				       accel_group);
+
+  /* This function generates the menu items. Pass the item factory,
+     the number of items in the array, the array itself, and any
+     callback data for the the menu items. */
+  gtk_item_factory_create_items (item_factory,
+				 sizeof (menu_items) / sizeof (menu_items[0]),
+				 menu_items, NULL);
+
+  /* Attach the new accelerator group to the window. */
+  gtk_window_add_accel_group (GTK_WINDOW (window), accel_group);
+
+  /* Finally, return the actual menu bar created by the item factory. */
+  return gtk_item_factory_get_widget (item_factory, "<main>");
+}
+
+static void
+trac_toggled_cb (GtkWidget * w, void *data)
+{
+  trac_followout = !trac_followout;
+  trac_follow_end ();
+}
+
+int
+main (int argc, char *argv[])
+{
+  GIOChannel *chan = 0;
+  GtkSourceLanguagesManager *lm;
+  guint inputio;
+  int traced = 0, ix;
+  GError *err = 0;
+  char buf[200];
+  char hn[64];
+  /* initialization */
+  gtk_init (&argc, &argv);
+  for (ix = 1; ix < argc; ix++)
+    {
+      if (!strcmp (argv[ix], "--traced") || !strcmp (argv[ix], "-T"))
+	traced = 1;
+#ifndef NDEBUG
+      if (!strcmp (argv[ix], "--debug") || !strcmp (argv[ix], "-D"))
+	dbgfile = stderr;
+#endif
+    }
+  arrow_right_15x15_pixbuf =
+    gdk_pixbuf_new_from_xpm_data (arrow_right_15x15_xpm);
+  indifferent_13x14_pixbuf =
+    gdk_pixbuf_new_from_xpm_data (indifferent_13x14_xpm);
+  sb_info_10x15_pixbuf = gdk_pixbuf_new_from_xpm_data (sb_info_10x15_xpm);
+  mini_info_12x14_pixbuf = gdk_pixbuf_new_from_xpm_data (mini_info_12x14_xpm);
+  key_7x11_pixbuf = gdk_pixbuf_new_from_xpm_data (key_7x11_xpm);
+  tree_24x24_pixbuf = gdk_pixbuf_new_from_xpm_data (tree_24x24_xpm);
+  action_table = g_hash_table_new (g_str_hash, g_str_equal);
+  lm = gtk_source_languages_manager_new ();
+  chan = g_io_channel_unix_new (STDIN_FILENO);
+  g_io_channel_set_encoding (chan, (const gchar *) "latin1", &err);
+  inputio = g_io_add_watch (chan, G_IO_IN, ioreader, (gpointer) 0);
+  window = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+  gtk_container_set_border_width (GTK_CONTAINER (window), 1);
+  gtk_window_set_default_size (GTK_WINDOW (window), 450, 300);
+  gtk_window_set_title (GTK_WINDOW (window), "simple GCC probe");
+  vbox = gtk_vbox_new (FALSE, 2);
+  gtk_container_add (GTK_CONTAINER (window), vbox);
+  menubar = get_menubar_menu (window);
+  gtk_box_pack_start (GTK_BOX (vbox), menubar, FALSE, TRUE, 1);
+  gethostname (hn, sizeof (hn));
+  snprintf (buf, sizeof (buf), "GCC simple probe pid %d on %s",
+	    (int) getpid (), hn);
+  buf[sizeof (buf) - 1] = 0;
+  fileinfo_array = g_ptr_array_sized_new (200);
+  pointinfo_array = g_ptr_array_sized_new (400);
+  infodialog_array = g_ptr_array_sized_new (300);
+  mainlabel = gtk_label_new (buf);
+  gtk_box_pack_start (GTK_BOX (vbox), mainlabel, FALSE, FALSE, 1);
+  versionlab = gtk_label_new ((char *) 0);
+  gtk_label_set_selectable (GTK_LABEL (versionlab), TRUE);
+  gtk_box_pack_start (GTK_BOX (vbox), versionlab, FALSE, FALSE, 1);
+  notebook = gtk_notebook_new ();
+  gtk_notebook_set_scrollable (GTK_NOTEBOOK (notebook), TRUE);
+  gtk_box_pack_start (GTK_BOX (vbox), notebook, TRUE, TRUE, 1);
+  stabar = gtk_statusbar_new ();
+  stid_pass =
+    gtk_statusbar_get_context_id (GTK_STATUSBAR (stabar), "passctx");
+  gtk_statusbar_push (GTK_STATUSBAR (stabar), stid_pass, "no pass");
+  gtk_box_pack_start (GTK_BOX (vbox), stabar, FALSE, FALSE, 1);
+  lang_mgr = gtk_source_languages_manager_new ();
+  g_signal_connect (G_OBJECT (window), "destroy",
+		    G_CALLBACK (destroy_cb), NULL);
+  register_action ("PROB_destroydialog", destroydialog_act, (void *) 0);
+  register_action ("PROB_dialogchoice", dialogchoice_act, (void *) 0);
+  register_action ("PROB_dialogcontent", dialogcontent_act, (void *) 0);
+  register_action ("PROB_dialognavig", dialognavig_act, (void *) 0);
+  register_action ("PROB_file", file_act, (void *) 0);
+  register_action ("PROB_infopoint", infopoint_act, (void *) 0);
+  register_action ("PROB_message", message_act, (void *) 0);
+  register_action ("PROB_showdialog", showdialog_act, (void *) 0);
+  register_action ("PROB_version", version_act, (void *) 0);
+  if (traced)
+    {
+      char buf[100];
+      memset (buf, 0, sizeof (buf));
+      snprintf (buf, sizeof (buf) - 1, "GCC simple probe trace pid %ld",
+		(long) getpid ());
+      tracwindow = gtk_window_new (GTK_WINDOW_TOPLEVEL);
+      gtk_window_set_default_size (GTK_WINDOW (tracwindow), 500, 400);
+      g_signal_connect (G_OBJECT (tracwindow), "destroy",
+			G_CALLBACK (tracdestroy_cb), NULL);
+      gtk_container_set_border_width (GTK_CONTAINER (tracwindow), 1);
+      gtk_window_set_title (GTK_WINDOW (tracwindow), "simple GCC trace");
+      tracbox = gtk_vbox_new (FALSE, 2);
+      dbgprintf ("tracbox %p", tracbox);
+      traccheck =
+	gtk_check_button_new_with_label ("autoscroll follow output");
+      g_signal_connect (traccheck, "toggled", G_CALLBACK (trac_toggled_cb),
+			NULL);
+      gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON (traccheck), 1);
+      tracscroll = gtk_scrolled_window_new (0, 0);
+      gtk_scrolled_window_set_policy (GTK_SCROLLED_WINDOW (tracscroll),
+				      GTK_POLICY_NEVER, GTK_POLICY_AUTOMATIC);
+      gtk_container_add (GTK_CONTAINER (tracwindow), tracbox);
+      gtk_box_pack_start (GTK_BOX (tracbox), gtk_label_new (buf), FALSE,
+			  FALSE, 1);
+      gtk_box_pack_start (GTK_BOX (tracbox), traccheck, FALSE, FALSE, 1);
+      tractagtbl = gtk_text_tag_table_new ();
+      dbgprintf ("tractagtbl %p", tractagtbl);
+      tractxtbuf = gtk_text_buffer_new (tractagtbl);
+      dbgprintf ("tractxtbuf %p", tractxtbuf);
+      tractag_tim = gtk_text_buffer_create_tag (tractxtbuf, "tim",
+						"weight", PANGO_WEIGHT_BOLD,
+						"scale", PANGO_SCALE_SMALL,
+						"foreground",
+						"DarkGoldenrod4", (void *) 0);
+      tractag_title =
+	gtk_text_buffer_create_tag (tractxtbuf, "title", "scale",
+				    PANGO_SCALE_X_LARGE, "foreground", "red",
+				    (void *) 0);
+      tractag_imp =
+	gtk_text_buffer_create_tag (tractxtbuf, "imp", "scale",
+				    PANGO_SCALE_LARGE, "weight",
+				    PANGO_WEIGHT_BOLD, "foreground", "red",
+				    (void *) 0);
+      tractag_in =
+	gtk_text_buffer_create_tag (tractxtbuf, "in", "foreground", "blue",
+				    (void *) 0);
+      tractag_out =
+	gtk_text_buffer_create_tag (tractxtbuf, "out", "style",
+				    PANGO_STYLE_ITALIC, "foreground",
+				    "darkgreen", (void *) 0);
+      tracview = gtk_text_view_new_with_buffer (tractxtbuf);
+      dbgprintf ("tracview %p", tracview);
+      gtk_text_view_set_editable (GTK_TEXT_VIEW (tracview), FALSE);
+      gtk_text_view_set_wrap_mode (GTK_TEXT_VIEW (tracview), GTK_WRAP_CHAR);
+      dbgprintf ("tracscroll %p", tracscroll);
+      gtk_container_add (GTK_CONTAINER (tracscroll), tracview);
+      dbgprintf ("tracbox %p", tracbox);
+      gtk_box_pack_start (GTK_BOX (tracbox), tracscroll, TRUE, TRUE, 1);
+      insert_trace_time (1, "TRACE [compiled " __DATE__ "@" __TIME__ "]: ");
+      gtk_widget_show_all (tracwindow);
+    };
+  gtk_widget_show_all (window);
+  gtk_main ();
+  return 0;
+}
+
+/**** for emacs 
+  ++ Local Variables: ++
+  ++ compilation-directory: "." ++
+  ++ compile-command: "gcc -Wall -O -g $(pkg-config --cflags --libs gtksourceview-1.0 gtk+-2.0) -o $HOME/bin/simple-probe simple-probe.c" ++
+  ++ End: ++
+ ****/
+
+/* eof simple-probe.c */
diff --git a/gcc/Makefile.in b/gcc/Makefile.in
index 9c91fb5fab6..990b7d81bd0 100644
--- a/gcc/Makefile.in
+++ b/gcc/Makefile.in
@@ -194,6 +194,9 @@ build/gengtype-lex.o-warn = -Wno-error
 # SYSCALLS.c misses prototypes
 SYSCALLS.c.X-warn = -Wno-strict-prototypes -Wno-error
 
+## basilys.c contain tricky stuff 
+basilys.o-warn = -Wno-error
+
 # All warnings have to be shut off in stage1 if the compiler used then
 # isn't gcc; configure determines that.  WARN_CFLAGS will be either
 # $(GCC_WARN_CFLAGS), or nothing.
@@ -278,6 +281,17 @@ ZLIBINC = @zlibinc@
 GMPLIBS = @GMPLIBS@
 GMPINC = @GMPINC@
 
+### for Basilys
+# How to find PPL (Parma Polyhedra Library)
+PPLLIBS = @ppllibs@
+PPLINC = @pplinc@
+
+# How to file LTDL (LibTool DynLoader)
+LTDLLIBS = @ltdllibs@
+LTDLINC = @ltdlinc@
+LTDL_LDFLAGS= @ltdl_ldflags@
+#### end of Basilys stuff
+
 CPPLIB = ../libcpp/libcpp.a
 CPPINC = -I$(srcdir)/../libcpp/include
 
@@ -658,7 +672,7 @@ COMPILERS = cc1$(exeext) @all_compilers@
 
 # List of things which should already be built whenever we try to use xgcc
 # to compile anything (without linking).
-GCC_PASSES=xgcc$(exeext) cc1$(exeext) specs $(EXTRA_PASSES)
+GCC_PASSES=xgcc$(exeext) cc1$(exeext) specs compile-basilys-defs $(EXTRA_PASSES)
 
 # Directory to link to, when using the target `maketest'.
 DIR = ../gcc
@@ -873,7 +887,8 @@ BUILD_LIBDEPS= $(BUILD_LIBIBERTY)
 
 # How to link with both our special library facilities
 # and the system's installed libraries.
-LIBS = @LIBS@ $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBIBERTY) $(LIBDECNUMBER)
+LIBS = @LIBS@ $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBIBERTY) $(LIBDECNUMBER) \
+     $(PPLLIBS) $(GMPLIBS)  $(LTDLLIBS) $(GMPLIBS)
 
 # Any system libraries needed just for GNAT.
 SYSLIBS = @GNAT_LIBEXC@
@@ -898,6 +913,7 @@ BUILD_ERRORS = build/errors.o
 # libintl.h will be found in ../intl if we are using the included libintl.
 INCLUDES = -I. -I$(@D) -I$(srcdir) -I$(srcdir)/$(@D) \
 	   -I$(srcdir)/../include @INCINTL@ \
+	   $(PPLINC) $(LTDLINC) \
 	   $(CPPINC) $(GMPINC) $(DECNUMINC)
 
 .c.o:
@@ -1003,6 +1019,7 @@ OBJS-common = \
 	alias.o \
 	alloc-pool.o \
 	auto-inc-dec.o \
+	basilys.o \
 	bb-reorder.o \
 	bitmap.o \
 	bt-load.o \
@@ -1250,7 +1267,8 @@ OBJS = $(OBJS-common) $(OBJS-md) $(OBJS-archive)
 
 OBJS-onestep = libbackend.o $(OBJS-archive)
 
-BACKEND = main.o @TREEBROWSER@ libbackend.a $(CPPLIB) $(LIBDECNUMBER)
+COMPILER_PROBE_OBJ =  @COMPILER_PROBE@
+BACKEND = main.o @TREEBROWSER@ $(COMPILER_PROBE_OBJ) libbackend.a $(CPPLIB) $(LIBDECNUMBER)
 
 MOSTLYCLEANFILES = insn-flags.h insn-config.h insn-codes.h \
  insn-output.c insn-recog.c insn-emit.c insn-extract.c insn-peep.c \
@@ -1262,6 +1280,7 @@ MOSTLYCLEANFILES = insn-flags.h insn-config.h insn-codes.h \
  $(EXTRA_PARTS) $(EXTRA_PROGRAMS) gcc-cross$(exeext) \
  protoize$(exeext) unprotoize$(exeext) \
  $(SPECS) collect2$(exeext) \
+ compile-basilys-defs \
  gcov-iov$(build_exeext) gcov$(exeext) gcov-dump$(exeext) \
  *.[0-9][0-9].* *.[si] *-checksum.c libbackend.a libgcc.mk
 
@@ -1553,7 +1572,7 @@ gcc-cross$(exeext): xgcc$(exeext)
 dummy-checksum.o : dummy-checksum.c
 
 cc1-dummy$(exeext): $(C_OBJS) dummy-checksum.o $(BACKEND) $(LIBDEPS)
-	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(C_OBJS) dummy-checksum.o \
+	$(CC) $(ALL_CFLAGS) $(LDFLAGS) $(LTDL_LDFLAGS) -o $@ $(C_OBJS) dummy-checksum.o \
 	  $(BACKEND) $(LIBS) $(GMPLIBS)
 
 cc1-checksum.c : cc1-dummy$(exeext) build/genchecksum$(build_exeext)
@@ -1562,7 +1581,7 @@ cc1-checksum.c : cc1-dummy$(exeext) build/genchecksum$(build_exeext)
 cc1-checksum.o : cc1-checksum.c
 
 cc1$(exeext): $(C_OBJS) cc1-checksum.o $(BACKEND) $(LIBDEPS)
-	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(C_OBJS) cc1-checksum.o \
+	$(CC) $(ALL_CFLAGS) $(LDFLAGS) $(LTDL_LDFLAGS) -o $@ $(C_OBJS) cc1-checksum.o \
 	  $(BACKEND) $(LIBS) $(GMPLIBS)
 
 #
@@ -2322,6 +2341,12 @@ targhooks.o : targhooks.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TREE_H) \
    $(MACHMODE_H) $(TARGET_DEF_H) $(TARGET_H) $(GGC_H) gt-targhooks.h \
    $(OPTABS_H)
 
+#### added for Basilys
+basilys.o:  basilys.c  \
+   $(CONFIG_H) $(SYSTEM_H) $(TIMEVAR_H) $(TM_H)  $(TREE_H)  $(GGC_H)  \
+   tree-pass.h basilys.h gt-basilys.h
+### end of Basilys stuff
+
 toplev.o : toplev.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
    version.h $(RTL_H) $(FUNCTION_H) $(FLAGS_H) xcoffout.h input.h \
    $(INSN_ATTR_H) output.h $(DIAGNOSTIC_H) debug.h insn-config.h intl.h \
@@ -3099,6 +3124,7 @@ GTFILES = $(srcdir)/input.h $(srcdir)/coretypes.h \
   $(srcdir)/dojump.c \
   $(srcdir)/emit-rtl.c $(srcdir)/except.c $(srcdir)/explow.c $(srcdir)/expr.c \
   $(srcdir)/function.c $(srcdir)/except.h \
+  $(srcdir)/basilys.h \
   $(srcdir)/gcse.c $(srcdir)/integrate.c $(srcdir)/lists.c $(srcdir)/optabs.c \
   $(srcdir)/profile.c $(srcdir)/regclass.c \
   $(srcdir)/reg-stack.c $(srcdir)/cfglayout.c $(srcdir)/cfglayout.h \
@@ -3116,6 +3142,8 @@ GTFILES = $(srcdir)/input.h $(srcdir)/coretypes.h \
   $(srcdir)/tree-ssa-structalias.c $(srcdir)/tree-parloops.c \
   $(srcdir)/omp-low.c $(srcdir)/varpool.c \
   $(srcdir)/targhooks.c $(out_file) $(srcdir)/passes.c $(srcdir)/cgraphunit.c \
+  $(patsubst %.o, $(srcdir)/%.c, $(COMPILER_PROBE_OBJ) ) \
+  $(srcdir)/basilys.c \
   @all_gtfiles@
 
 GTFILES_H = $(subst /,-, $(patsubst $(srcdir)/%,gt-%, $(patsubst %.c,%.h, \
@@ -4464,3 +4492,11 @@ po/gcc.pot: force
 	$(MAKE) srcextra
 	AWK=$(AWK) $(SHELL) $(srcdir)/po/exgettext \
 		$(XGETTEXT) gcc $(srcdir)
+
+
+## definition for basilys internal compilation
+compile-basilys-defs:	
+	echo '#generated compile-basilys-defs' > $@
+	echo 'ALL_CFLAGS="' $(ALL_CFLAGS) '"' >> $@
+	echo 'ALL_CPPFLAGS="' -I$(PWD) $(ALL_CPPFLAGS) '"' >> $@
+### end of basilys stuff
\ No newline at end of file
diff --git a/gcc/basic-block.h b/gcc/basic-block.h
index c04c6f6ee53..c04ef896102 100644
--- a/gcc/basic-block.h
+++ b/gcc/basic-block.h
@@ -335,6 +335,20 @@ enum bb_flags
   BB_NONTHREADABLE_BLOCK = 1 << 11
 };
 
+
+/* Basile adds a flag to accept RTL basic blocks in some special code
+   (like the compiler probe); declared in compiler-probe.h if enabled;
+   used to disable some asserts of BB_RTL flags in some
+   tree-flow-inline.h functons */
+#if ENABLE_COMPILER_PROBE
+extern int comprobe_bb_ok_rtl;
+#else
+#define comprobe_bb_ok_rtl 0
+#endif /*ENABLE_COMPILER_PROBE*/
+
+
+
+
 /* Dummy flag for convenience in the hot/cold partitioning code.  */
 #define BB_UNPARTITIONED	0
 
diff --git a/gcc/basilys.c b/gcc/basilys.c
new file mode 100644
index 00000000000..fbad1b7295c
--- /dev/null
+++ b/gcc/basilys.c
@@ -0,0 +1,5645 @@
+/* Basile's static analysis (should have a better name) basilys.c
+   Copyright (C) 2008 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+   Indented with GNU indent 
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GCC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.   If not see
+<http://www.gnu.org/licenses/>.   
+  */
+
+/* for debugging -fbasilys-debug is useful */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "obstack.h"
+#include "tm.h"
+#include "tree.h"
+#include "tree-pass.h"
+#include "tree-dump.h"
+#include "basic-block.h"
+#include "timevar.h"
+#include "errors.h"
+#include "ggc.h"
+#include "cgraph.h"
+#include "diagnostic.h"
+#include "flags.h"
+#include "toplev.h"
+#include "options.h"
+#include "params.h"
+#include "real.h"
+#include "prefix.h"
+
+#include "compiler-probe.h"
+
+
+#if HAVE_PARMAPOLY
+#include <ppl_c.h>
+#else
+#error required parma polyedral library PPL
+#endif /*HAVE_PARMAPOLY */
+
+#if HAVE_LIBTOOLDYNL
+#include <ltdl.h>
+#else
+#error required libtool dynamic loader library LTDL
+#endif /*HAVE_LIBTOOLDYNL */
+
+#include "basilys.h"
+
+
+#define MINOR_SIZE_KILOWORD PARAM_VALUE(PARAM_BASILYS_MINOR_ZONE)
+#define FULL_FREQ PARAM_VALUE(PARAM_BASILYS_FULL_FREQ)
+
+/* *INDENT-OFF* */
+basilys_ptr_t basilys_globarr[BGLOB__LASTGLOB];
+void* basilys_startalz=NULL;
+void* basilys_endalz;
+char* basilys_curalz;
+void** basilys_storalz;
+
+struct callframe_basilys_st* basilys_topframe; 
+struct basilyslocalsptr_st* basilys_localtab; 
+struct basilysspecial_st* basilys_newspeclist;
+struct basilysspecial_st* basilys_oldspeclist;
+unsigned long basilys_kilowords_sincefull;
+/* number of full & any basilys garbage collections */
+unsigned long basilys_nb_full_garbcoll;
+unsigned long basilys_nb_garbcoll;
+void* basilys_touched_cache[BASILYS_TOUCHED_CACHE_SIZE];
+bool basilys_prohibit_garbcoll;
+
+long basilys_dbgcounter;
+
+void (*basilys_extra_scanrout_p)(void);
+
+int basilys_last_global_ix = BGLOB__LASTGLOB;
+
+/* our copying garbage collector needs a vector of basilys_ptr_t to
+   scan and an hashtable of basilys_ptr_t which are local variables
+   copied into GGC heap;  */
+static GTY(()) VEC(basilys_ptr_t,gc) *bscanvec;
+
+
+struct basilocalsptr_st GTY(()) {
+  unsigned char lenix;			/* length is prime, this is the index of length */
+  int nbent;
+  basilys_ptr_t  GTY((length("basilys_primtab[%h.lenix]"))) ptrtab[FLEXIBLE_DIM];
+};
+
+static GTY(()) struct basilocalsptr_st* blocaltab; 
+
+
+
+
+/* *INDENT-ON* */
+
+/* to code case ALL_OBMAG_SPECIAL_CASES: */
+#define ALL_OBMAG_SPECIAL_CASES			\
+         OBMAG_SPEC_FILE:			\
+    case OBMAG_SPEC_MPFR:			\
+    case OBMAG_SPECPPL_COEFFICIENT:    		\
+    case OBMAG_SPECPPL_LINEAR_EXPRESSION:	\
+    case OBMAG_SPECPPL_CONSTRAINT:		\
+    case OBMAG_SPECPPL_CONSTRAINT_SYSTEM:	\
+    case OBMAG_SPECPPL_GENERATOR:		\
+    case OBMAG_SPECPPL_GENERATOR_SYSTEM
+
+/* Obstack used for reading names */
+static struct obstack bname_obstack;
+
+
+/* random data for generating hashcodes */
+static struct drand48_data randata;
+
+long
+basilys_lrand (void)
+{
+  long lh = 0;
+  lrand48_r (&randata, &lh);
+  return lh;
+}
+
+
+static inline void
+delete_special (struct basilysspecial_st *sp)
+{
+  switch (sp->discr->object_magic)
+    {
+    case OBMAG_SPEC_FILE:
+      if (sp->val.sp_file)
+	{
+	  fclose (sp->val.sp_file);
+	  sp->val.sp_file = NULL;
+	};
+      break;
+    case OBMAG_SPEC_MPFR:
+      if (sp->val.sp_mpfr)
+	{
+	  mpfr_clear (sp->val.sp_mpfr);
+	  free (sp->val.sp_mpfr);
+	  sp->val.sp_mpfr = NULL;
+	};
+      break;
+    case OBMAG_SPECPPL_COEFFICIENT:
+      if (sp->val.sp_coefficient)
+	ppl_delete_Coefficient (sp->val.sp_coefficient);
+      sp->val.sp_coefficient = NULL;
+      break;
+    case OBMAG_SPECPPL_LINEAR_EXPRESSION:
+      if (sp->val.sp_linear_expression)
+	ppl_delete_Linear_Expression (sp->val.sp_linear_expression);
+      sp->val.sp_linear_expression = NULL;
+      break;
+    case OBMAG_SPECPPL_CONSTRAINT:
+      if (sp->val.sp_constraint)
+	ppl_delete_Constraint (sp->val.sp_constraint);
+      sp->val.sp_constraint = NULL;
+      break;
+    case OBMAG_SPECPPL_CONSTRAINT_SYSTEM:
+      if (sp->val.sp_constraint_system)
+	ppl_delete_Constraint_System (sp->val.sp_constraint_system);
+      sp->val.sp_constraint_system = NULL;
+      break;
+    case OBMAG_SPECPPL_GENERATOR:
+      if (sp->val.sp_generator)
+	ppl_delete_Generator (sp->val.sp_generator);
+      sp->val.sp_generator = NULL;
+      break;
+    case OBMAG_SPECPPL_GENERATOR_SYSTEM:
+      if (sp->val.sp_generator_system)
+	ppl_delete_Generator_System (sp->val.sp_generator_system);
+      sp->val.sp_generator_system = NULL;
+      break;
+    default:
+      break;
+    }
+}
+
+#define FORWARDED_DISCR (basilysobject_ptr_t)1
+static basilys_ptr_t forwarded_copy (basilys_ptr_t);
+
+#ifdef ENABLE_CHECKING
+/* only for debugging, to be set from the debugger */
+static void *bstrangelocal;
+static long nbaddlocalptr;
+
+static FILE *debughack_file;
+void *basilys_checkedp_ptr1;
+void *basilys_checkedp_ptr2;
+
+#endif
+
+
+static inline void *
+forwarded (void *ptr)
+{
+  basilys_ptr_t p = ptr;
+  if (p && basilys_is_young (p))
+    {
+      if (p->u_discr == FORWARDED_DISCR)
+	p = ((struct basilysforward_st *) p)->forward;
+      else
+	p = forwarded_copy (p);
+    }
+  return p;
+}
+
+#if ENABLE_CHECKING
+#define FORWARDED(P) do {if (P) { 					\
+      if (debughack_file)						\
+	fprintf(debughack_file,"%s:%d forwarded %p\n",			\
+		basename(__FILE__), __LINE__, (void*)(P));		\
+      (P) = forwarded((P));} }  while(0)
+#else
+#define FORWARDED(P) do {if (P) { 					\
+      (P) = forwarded((P));} }  while(0)
+#endif
+static void scanning (basilys_ptr_t);
+
+
+static void
+add_localptr (basilys_ptr_t p)
+{
+  HOST_WIDE_INT ix;
+  int h, k;
+  long primsiz = basilys_primtab[blocaltab->lenix];
+  if (!p)
+    return;
+#ifdef ENABLE_CHECKING
+  nbaddlocalptr++;
+  if (p == bstrangelocal)
+    {
+      debugeprintf ("adding #%ld bstrangelocal %p", nbaddlocalptr,
+		    (void *) p);
+    }
+#endif
+  gcc_assert ((void *) p != (void *) FORWARDED_DISCR);
+  gcc_assert (primsiz > 0);
+  ix = (HOST_WIDE_INT) p;
+  ix ^= ((HOST_WIDE_INT) p) >> 11;
+  ix &= 0x3fffffff;
+  h = (int) ix % primsiz;
+  for (k = h; k < primsiz; k++)
+    {
+      if (!blocaltab->ptrtab[k])
+	{
+	  blocaltab->ptrtab[k] = p;
+	  blocaltab->nbent++;
+	  return;
+	}
+      else if (blocaltab->ptrtab[k] == p)
+	return;
+    }
+  for (k = 0; k < h; k++)
+    {
+      if (!blocaltab->ptrtab[k])
+	{
+	  blocaltab->ptrtab[k] = p;
+	  blocaltab->nbent++;
+	  return;
+	}
+      else if (blocaltab->ptrtab[k] == p)
+	return;
+    }
+  /* the only way to reach this point is that blocaltab is
+     full; this should never happen, since it was allocated bigger
+     than the number of locals! */
+  gcc_unreachable ();
+}
+
+
+#if ENABLE_CHECKING
+/***
+ * check our call frames
+ ***/
+static inline void
+check_pointer_at (const char msg[], long count, basilys_ptr_t * pptr,
+		  const char *filenam, int lineno)
+{
+  basilys_ptr_t ptr = *pptr;
+  if (!ptr)
+    return;
+  if (!ptr->u_discr)
+    fatal_error
+      ("<%s#%ld> corrupted pointer %p (at %p) without discr at %s:%d", msg,
+       count, (void *) ptr, (void *) pptr, basename (filenam), lineno);
+  switch (ptr->u_discr->object_magic)
+    {
+    case OBMAG_OBJECT:
+    case OBMAG_DECAY:
+    case OBMAG_BOX:
+    case OBMAG_MULTIPLE:
+    case OBMAG_CLOSURE:
+    case OBMAG_ROUTINE:
+    case OBMAG_LIST:
+    case OBMAG_PAIR:
+    case OBMAG_TRIPLE:
+    case OBMAG_INT:
+    case OBMAG_MIXINT:
+    case OBMAG_REAL:
+    case OBMAG_STRING:
+    case OBMAG_STRBUF:
+    case OBMAG_TREE:
+    case OBMAG_BASICBLOCK:
+    case OBMAG_EDGE:
+    case OBMAG_MAPOBJECTS:
+    case OBMAG_MAPTREES:
+    case OBMAG_MAPSTRINGS:
+    case OBMAG_MAPBASICBLOCKS:
+    case OBMAG_MAPEDGES:
+    case ALL_OBMAG_SPECIAL_CASES:
+      break;
+    default:
+      fatal_error ("<%s#%ld> bad pointer %p (at %p) bad magic %d at %s:%d",
+		   msg, count, (void *) ptr, (void *) pptr,
+		   (int) ptr->u_discr->object_magic, basename (filenam),
+		   lineno);
+    }
+}
+
+static long nbcheckcallframes;
+static long thresholdcheckcallframes;
+
+
+void
+basilys_check_call_frames_at (int noyoungflag, const char *msg,
+			      const char *filenam, int lineno)
+{
+  struct callframe_basilys_st *cfram = NULL;
+  int nbfram = 0, nbvar = 0;
+  nbcheckcallframes++;
+  if (!msg)
+    msg = "/";
+  if (thresholdcheckcallframes > 0
+      && nbcheckcallframes > thresholdcheckcallframes)
+    {
+      debugeprintf
+	("start check_call_frames#%ld {%s} from %s:%d",
+	 nbcheckcallframes, msg, basename (filenam), lineno);
+    }
+  for (cfram = basilys_topframe; cfram != NULL; cfram = cfram->prev)
+    {
+      int varix = 0;
+      nbfram++;
+      if (cfram->clos)
+	{
+	  if (noyoungflag && basilys_is_young (cfram->clos))
+	    fatal_error
+	      ("bad frame <%s#%ld> unexpected young closure %p in frame %p at %s:%d",
+	       msg, nbcheckcallframes,
+	       (void *) cfram->clos, (void *) cfram, basename (filenam),
+	       lineno);
+
+	  check_pointer_at (msg, nbcheckcallframes,
+			    (basilys_ptr_t *) (void *) &cfram->clos, filenam,
+			    lineno);
+	  if (cfram->clos->discr->object_magic != OBMAG_CLOSURE)
+	    fatal_error
+	      ("bad frame <%s#%ld> invalid closure %p in frame %p at %s:%d",
+	       msg, nbcheckcallframes,
+	       (void *) cfram->clos, (void *) cfram, basename (filenam),
+	       lineno);
+	}
+      for (varix = ((int) cfram->nbvar) - 1; varix >= 0; varix--)
+	{
+	  nbvar++;
+	  if (noyoungflag && cfram->varptr[varix] != NULL
+	      && basilys_is_young (cfram->varptr[varix]))
+	    fatal_error
+	      ("bad frame <%s#%ld> unexpected young pointer %p in frame %p at %s:%d",
+	       msg, nbcheckcallframes, (void *) cfram->varptr[varix],
+	       (void *) cfram, basename (filenam), lineno);
+
+	  check_pointer_at (msg, nbcheckcallframes, &cfram->varptr[varix],
+			    filenam, lineno);
+	}
+    }
+  if (thresholdcheckcallframes > 0
+      && nbcheckcallframes > thresholdcheckcallframes)
+    debugeprintf ("end check_call_frames#%ld {%s} %d frames/%d vars %s:%d",
+		  nbcheckcallframes, msg, nbfram, nbvar, basename (filenam),
+		  lineno);
+  if (debughack_file)
+    {
+      fprintf (debughack_file,
+	       "check_call_frames#%ld {%s} %d frames/%d vars %s:%d\n",
+	       nbcheckcallframes, msg, nbfram, nbvar, basename (filenam),
+	       lineno);
+      fflush (debughack_file);
+    }
+}
+
+void
+basilys_caught_assign_at (void *ptr, const char *fil, int lin)
+{
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "caught assign %p at %s:%d\n", ptr,
+	       basename (fil), lin);
+      fflush (debughack_file);
+    }
+  debugeprintf ("caught assign %p at %s:%d", ptr, basename (fil), lin);
+}
+
+static long nbcbreak;
+
+void
+basilys_cbreak_at (const char *msg, const char *fil, int lin)
+{
+  nbcbreak++;
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "CBREAK#%ld AT %s:%d - %s\n", nbcbreak,
+	       basename (fil), lin, msg);
+      fflush (debughack_file);
+    };
+  debugeprintf_raw ("%s:%d: CBREAK#%ld %s\n", basename (fil), lin, nbcbreak,
+		    msg);
+}
+
+#endif
+
+/***
+ * our copying garbage collector 
+ ***/
+void
+basilys_garbcoll (size_t wanted, bool needfull)
+{
+  long primix = 0;
+  int locdepth = 0;
+  int nbloc = 0;
+  int nbglob = 0;
+  int locsiz = 0;
+  int ix = 0;
+  struct callframe_basilys_st *cfram = NULL;
+  basilys_ptr_t *storp = NULL;
+  struct basilysspecial_st *specp = NULL;
+  struct basilysspecial_st **prevspecptr = NULL;
+  struct basilysspecial_st *nextspecp = NULL;
+  if (basilys_prohibit_garbcoll)
+    fatal_error ("basilys garbage collection prohibited");
+  basilys_nb_garbcoll++;
+#if ENABLE_CHECKING
+#warning debug message garbcoll start
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "%s:%d start garbcoll #%ld",
+	       basename (__FILE__), __LINE__, basilys_nb_garbcoll);
+      fflush (debughack_file);
+    }
+#endif
+  basilys_check_call_frames (BASILYS_ANYWHERE, "before garbage collection");
+  gcc_assert ((char *) basilys_startalz < (char *) basilys_endalz);
+  gcc_assert ((char *) basilys_curalz >= (char *) basilys_startalz
+	      && (char *) basilys_curalz < (char *) basilys_storalz);
+  gcc_assert ((char *) basilys_storalz < (char *) basilys_endalz);
+  bscanvec = VEC_alloc (basilys_ptr_t, gc, 1024 + 32 * MINOR_SIZE_KILOWORD);
+  wanted += wanted / 4 + MINOR_SIZE_KILOWORD * 1000;
+  wanted |= 0x3fff;
+  wanted++;
+  if (wanted < MINOR_SIZE_KILOWORD * sizeof (void *) * 1024)
+    wanted = MINOR_SIZE_KILOWORD * sizeof (void *) * 1024;
+  /* compute number of locals and depth of call stack */
+  nbglob = BGLOB__LASTGLOB;
+  for (cfram = basilys_topframe; cfram != NULL; cfram = cfram->prev)
+    {
+      locdepth++;
+      /* we should never have more than a few thousand locals in a
+         call frame, so we check this */
+      gcc_assert (cfram->nbvar < (int) BASILYS_MAXNBLOCALVAR);
+      nbloc += cfram->nbvar;
+    }
+  locsiz = 200 + (5 * (locdepth + nbloc + nbglob + 100)) / 4;
+  locsiz |= 0xff;
+  for (primix = 5;
+       basilys_primtab[primix] > 0
+       && basilys_primtab[primix] <= locsiz; primix++);
+  locsiz = basilys_primtab[primix];
+  gcc_assert (locsiz > 10);
+  blocaltab =
+    ggc_alloc_cleared (sizeof (struct basilocalsptr_st) +
+		       locsiz * sizeof (void *));
+  blocaltab->lenix = primix;
+  for (ix = 0; ix < BGLOB__LASTGLOB; ix++)
+    FORWARDED (basilys_globarr[ix]);
+  if (basilys_extra_scanrout_p)
+    (*basilys_extra_scanrout_p) ();
+  for (cfram = basilys_topframe; cfram != NULL; cfram = cfram->prev)
+    {
+      int varix;
+      if (cfram->clos)
+	{
+	  FORWARDED (cfram->clos);
+	  add_localptr ((basilys_ptr_t) (cfram->clos));
+	}
+      for (varix = ((int) cfram->nbvar) - 1; varix >= 0; varix--)
+	{
+	  if (!cfram->varptr[varix])
+	    continue;
+	  FORWARDED (cfram->varptr[varix]);
+	  add_localptr (cfram->varptr[varix]);
+	}
+    };
+  /* scan the store list */
+  for (storp = (basilys_ptr_t *) basilys_storalz;
+       (char *) storp < (char *) basilys_endalz; storp++)
+    {
+      if (*storp)
+	scanning (*storp);
+    }
+  memset (basilys_touched_cache, 0, sizeof (basilys_touched_cache));
+  /* sort of Chesney loop */
+  while (!VEC_empty (basilys_ptr_t, bscanvec))
+    {
+      basilys_ptr_t p = VEC_pop (basilys_ptr_t, bscanvec);
+      if (!p)
+	continue;
+#if ENABLE_CHECKING
+      if (debughack_file)
+	fprintf (debughack_file, "chesney scan %p\n", (void *) p);
+#endif
+      scanning (p);
+    }
+  /* delete every unmarked special on the new list and clear it */
+  for (specp = basilys_newspeclist; specp; specp = specp->nextspec)
+    {
+      gcc_assert (basilys_is_young (specp));
+      if (specp->mark)
+	continue;
+      delete_special (specp);
+    }
+  basilys_newspeclist = NULL;
+  /* free the previous young zone and allocate a new one */
+#if ENABLE_CHECKING
+  if (debughack_file)
+    {
+      fprintf (debughack_file,
+	       "%s:%d free previous young %p - %p GC#%ld\n",
+	       basename (__FILE__), __LINE__, basilys_startalz,
+	       basilys_endalz, basilys_nb_garbcoll);
+      fflush (debughack_file);
+    }
+  memset (basilys_startalz, 0,
+	  (char *) basilys_endalz - (char *) basilys_startalz);
+#endif
+  free (basilys_startalz);
+  basilys_startalz = basilys_endalz = basilys_curalz = NULL;
+  basilys_storalz = NULL;
+  basilys_kilowords_sincefull += wanted / (1024 * sizeof (void *));
+  if (basilys_kilowords_sincefull >
+      (unsigned long) MINOR_SIZE_KILOWORD * FULL_FREQ)
+    needfull = TRUE;
+  basilys_startalz = basilys_curalz =
+    xcalloc (sizeof (void *), wanted / sizeof (void *));
+  basilys_endalz = (char *) basilys_curalz + wanted;
+  basilys_storalz = ((void **) basilys_endalz) - 2;
+  if (needfull)
+    {
+      bool wasforced = ggc_force_collect;
+      basilys_nb_full_garbcoll++;
+      debugeprintf ("basilys_garbcoll #%ld fullgarbcoll #%ld",
+		    basilys_nb_garbcoll, basilys_nb_full_garbcoll);
+      /* clear marks on the old spec list */
+      for (specp = basilys_oldspeclist; specp; specp = specp->nextspec)
+	specp->mark = 0;
+      /* force major collection */
+      ggc_force_collect = true;
+      ggc_collect ();
+      ggc_force_collect = wasforced;
+      /* delete the unmarked spec */
+      prevspecptr = &basilys_oldspeclist;
+      for (specp = basilys_oldspeclist; specp; specp = nextspecp)
+	{
+	  nextspecp = specp->nextspec;
+	  if (specp->mark)
+	    {
+	      prevspecptr = &specp->nextspec;
+	      continue;
+	    }
+	  delete_special (specp);
+	  memset (specp, 0, sizeof (*specp));
+	  ggc_free (specp);
+	  *prevspecptr = nextspecp;
+	}
+      basilys_kilowords_sincefull = 0;
+    }
+  ggc_free (blocaltab);
+  blocaltab = NULL;
+  ggc_free (bscanvec);
+  bscanvec = NULL;
+  basilys_check_call_frames (BASILYS_NOYOUNG, "after garbage collection");
+#if ENABLE_CHECKING
+#warning debug message garbcoll end
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "%s:%d end %s garbcoll #%ld",
+	       basename (__FILE__), __LINE__,
+	       needfull ? "full" : "minor", basilys_nb_garbcoll);
+      fflush (debughack_file);
+    }
+#endif
+}
+
+
+static basilys_ptr_t
+forwarded_copy (basilys_ptr_t p)
+{
+  basilys_ptr_t n = 0;
+  int mag = 0;
+  gcc_assert (basilys_is_young (p));
+  gcc_assert (p->u_discr && p->u_discr != FORWARDED_DISCR);
+  if (p->u_discr->obj_class == FORWARDED_DISCR)
+    mag =
+      ((basilysobject_ptr_t)
+       (((struct basilysforward_st *) p->u_discr)->forward))->object_magic;
+  else
+    mag = p->u_discr->object_magic;
+  switch (mag)
+    {
+    case OBMAG_OBJECT:
+      {
+	struct basilysobject_st *src = (void *) p;
+	struct basilysobject_st *dst =
+	  ggc_alloc_cleared (offsetof (struct basilysobject_st,
+				       obj__tabfields));
+	unsigned oblen = src->obj_len;
+	int ix;
+	*dst = *src;
+	if (oblen > 0)
+	  {
+	    dst->obj_vartab = ggc_alloc_cleared (sizeof (void *) * oblen);
+	    for (ix = (int) oblen - 1; ix >= 0; ix--)
+	      dst->obj_vartab[ix] = src->obj_vartab[ix];
+	  }
+	else
+	  dst->obj_vartab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_DECAY:
+      {
+	struct basilysdecay_st *src = (void *) p;
+	struct basilysdecay_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysdecay_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_BOX:
+      {
+	struct basilysbox_st *src = (void *) p;
+	struct basilysbox_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysbox_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MULTIPLE:
+      {
+	struct basilysmultiple_st *src = (void *) p;
+	unsigned nbv = src->nbval;
+	int ix;
+	struct basilysmultiple_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmultiple_st) +
+			     nbv * sizeof (void *));
+	*dst = *src;
+	for (ix = (int) nbv; ix >= 0; ix--)
+	  dst->tabval[ix] = src->tabval[ix];
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_CLOSURE:
+      {
+	struct basilysclosure_st *src = (void *) p;
+	unsigned nbv = src->nbval;
+	int ix;
+	struct basilysclosure_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysclosure_st) +
+			     nbv * sizeof (void *));
+	*dst = *src;
+	for (ix = (int) nbv; ix >= 0; ix--)
+	  dst->tabval[ix] = src->tabval[ix];
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_ROUTINE:
+      {
+	struct basilysroutine_st *src = (void *) p;
+	unsigned nbv = src->nbval;
+	int ix;
+	struct basilysroutine_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysroutine_st) +
+			     nbv * sizeof (void *));
+	*dst = *src;
+	for (ix = (int) nbv; ix >= 0; ix--)
+	  dst->tabval[ix] = src->tabval[ix];
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_LIST:
+      {
+	struct basilyslist_st *src = (void *) p;
+	struct basilyslist_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilyslist_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_PAIR:
+      {
+	struct basilyspair_st *src = (void *) p;
+	struct basilyspair_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilyspair_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_TRIPLE:
+      {
+	struct basilystriple_st *src = (void *) p;
+	struct basilystriple_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilystriple_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_INT:
+      {
+	struct basilysint_st *src = (void *) p;
+	struct basilysint_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysint_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MIXINT:
+      {
+	struct basilysmixint_st *src = (void *) p;
+	struct basilysmixint_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmixint_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_REAL:
+      {
+	struct basilysreal_st *src = (void *) p;
+	struct basilysreal_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysreal_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case ALL_OBMAG_SPECIAL_CASES:
+      {
+	struct basilysspecial_st *src = (void *) p;
+	struct basilysspecial_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysspecial_st));
+	*dst = *src;
+	/* add the new copy to the old (major) special list */
+	dst->nextspec = basilys_oldspeclist;
+	basilys_oldspeclist = dst;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_STRING:
+      {
+	struct basilysstring_st *src = (void *) p;
+	int srclen = strlen (src->val);
+	struct basilysstring_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysstring_st) + srclen + 1);
+	*dst = *src;
+	memcpy (dst->val, src->val, srclen);
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_STRBUF:
+      {
+	struct basilysstrbuf_st *src = (void *) p;
+	unsigned blen = basilys_primtab[src->buflenix];
+	struct basilysstrbuf_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysstrbuf_st));
+	*dst = *src;
+	if (blen > 0)
+	  {
+	    dst->bufzn = ggc_alloc_cleared (1 + blen);
+	    memcpy (dst->bufzn, src->bufzn, blen);
+	  }
+	else
+	  dst->bufzn = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_TREE:
+      {
+	struct basilystree_st *src = (void *) p;
+	struct basilystree_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilystree_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_BASICBLOCK:
+      {
+	struct basilysbasicblock_st *src = (void *) p;
+	struct basilysbasicblock_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysbasicblock_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_EDGE:
+      {
+	struct basilysedge_st *src = (void *) p;
+	struct basilysedge_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysedge_st));
+	*dst = *src;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MAPOBJECTS:
+      {
+	struct basilysmapobjects_st *src = (void *) p;
+	int siz = basilys_primtab[src->lenix];
+	struct basilysmapobjects_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmapobjects_st));
+	*dst = *src;
+	if (siz > 0 && src->entab)
+	  {
+	    dst->entab = ggc_alloc_cleared (siz * sizeof (dst->entab[0]));
+	    memcpy (dst->entab, src->entab, siz * sizeof (dst->entab[0]));
+	  }
+	else
+	  dst->entab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MAPTREES:
+      {
+	struct basilysmaptrees_st *src = (void *) p;
+	int siz = basilys_primtab[src->lenix];
+	struct basilysmaptrees_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmaptrees_st));
+	*dst = *src;
+	if (siz > 0 && src->entab)
+	  {
+	    dst->entab = ggc_alloc_cleared (siz * sizeof (dst->entab[0]));
+	    memcpy (dst->entab, src->entab, siz * sizeof (dst->entab[0]));
+	  }
+	else
+	  dst->entab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MAPSTRINGS:
+      {
+	struct basilysmapstrings_st *src = (void *) p;
+	int siz = basilys_primtab[src->lenix];
+	struct basilysmapstrings_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmapstrings_st));
+	*dst = *src;
+	if (siz > 0 && src->entab)
+	  {
+	    dst->entab = ggc_alloc_cleared (siz * sizeof (dst->entab[0]));
+	    memcpy (dst->entab, src->entab, siz * sizeof (dst->entab[0]));
+	  }
+	else
+	  dst->entab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MAPBASICBLOCKS:
+      {
+	struct basilysmapbasicblocks_st *src = (void *) p;
+	int siz = basilys_primtab[src->lenix];
+	struct basilysmapbasicblocks_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmapbasicblocks_st));
+	*dst = *src;
+	if (siz > 0 && src->entab)
+	  {
+	    dst->entab = ggc_alloc_cleared (siz * sizeof (dst->entab[0]));
+	    memcpy (dst->entab, src->entab, siz * sizeof (dst->entab[0]));
+	  }
+	else
+	  dst->entab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    case OBMAG_MAPEDGES:
+      {
+	struct basilysmapedges_st *src = (void *) p;
+	int siz = basilys_primtab[src->lenix];
+	struct basilysmapedges_st *dst =
+	  ggc_alloc_cleared (sizeof (struct basilysmapedges_st));
+	*dst = *src;
+	if (siz > 0 && src->entab)
+	  {
+	    dst->entab = ggc_alloc_cleared (siz * sizeof (dst->entab[0]));
+	    memcpy (dst->entab, src->entab, siz * sizeof (dst->entab[0]));
+	  }
+	else
+	  dst->entab = NULL;
+	n = (basilys_ptr_t) dst;
+	break;
+      }
+    default:
+      debugeprintf ("forward invalid p=%p discr=%p magic=%d",
+		    (void *) p, (void *) p->u_discr, mag);
+      gcc_unreachable ();
+    }
+  if (n)
+    {
+      p->u_forward.discr = FORWARDED_DISCR;
+      p->u_forward.forward = n;
+#ifdef ENABLE_CHECKING
+      if (debughack_file)
+	{
+	  fprintf (debughack_file, "forwarded pushing %p to scan\n",
+		   (void *) n);
+	}
+#endif
+      VEC_safe_push (basilys_ptr_t, gc, bscanvec, n);
+    }
+  return n;
+  /* end of forwarded_copy */
+}
+
+
+
+/* the scanning routine is mostly chesney like; however some types,
+   including objects, strbuf, stringmaps, objectmaps, all the other
+   *maps, contain a pointer to a non value; this pointer should be
+   carefully updated if it was young */
+static void
+scanning (basilys_ptr_t p)
+{
+  if (!p)
+    return;
+  gcc_assert (p != (void *) 1);
+#if ENABLE_CHECKING
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "scanning %p\n", (void *) p);
+    }
+#endif
+  gcc_assert (p->u_discr && p->u_discr != (basilysobject_ptr_t) 1);
+  FORWARDED (p->u_discr);
+  gcc_assert (!basilys_is_young (p));
+  switch (p->u_discr->object_magic)
+    {
+    case OBMAG_OBJECT:
+      {
+	int ix;
+	struct basilysobject_st *src = (void *) p;
+	if (basilys_is_young (src->obj_vartab))
+	  {
+	    basilys_ptr_t *newtab =
+	      ggc_alloc_cleared (sizeof (void *) * src->obj_len);
+	    int ix;
+	    for (ix = (int) src->obj_len - 1; ix >= 0; ix--)
+	      newtab[ix] = src->obj_vartab[ix];
+	    src->obj_vartab = newtab;
+	  }
+	for (ix = (int) (src->obj_len) - 1; ix >= 0; ix--)
+	  FORWARDED (src->obj_vartab[ix]);
+	break;
+      }
+    case OBMAG_DECAY:
+      {
+	struct basilysdecay_st *src = (void *) p;
+	FORWARDED (src->val);
+	break;
+      }
+    case OBMAG_BOX:
+      {
+	struct basilysbox_st *src = (void *) p;
+	FORWARDED (src->val);
+	break;
+      }
+    case OBMAG_MULTIPLE:
+      {
+	struct basilysmultiple_st *src = (void *) p;
+	unsigned nbval = src->nbval;
+	int ix;
+	for (ix = (int) nbval - 1; ix >= 0; ix--)
+	  FORWARDED (src->tabval[ix]);
+	break;
+      }
+    case OBMAG_CLOSURE:
+      {
+	struct basilysclosure_st *src = (void *) p;
+	unsigned nbval = src->nbval;
+	int ix;
+	FORWARDED (src->rout);
+	for (ix = (int) nbval - 1; ix >= 0; ix--)
+	  FORWARDED (src->tabval[ix]);
+	break;
+      }
+    case OBMAG_ROUTINE:
+      {
+	struct basilysroutine_st *src = (void *) p;
+	unsigned nbval = src->nbval;
+	int ix;
+	for (ix = (int) nbval - 1; ix >= 0; ix--)
+	  FORWARDED (src->tabval[ix]);
+	break;
+      }
+    case OBMAG_LIST:
+      {
+	struct basilyslist_st *src = (void *) p;
+	FORWARDED (src->first);
+	FORWARDED (src->last);
+	break;
+      }
+    case OBMAG_PAIR:
+      {
+	struct basilyspair_st *src = (void *) p;
+	FORWARDED (src->hd);
+	FORWARDED (src->tl);
+	break;
+      }
+    case OBMAG_TRIPLE:
+      {
+	struct basilystriple_st *src = (void *) p;
+	FORWARDED (src->hd);
+	FORWARDED (src->mi);
+	FORWARDED (src->tl);
+	break;
+      }
+    case ALL_OBMAG_SPECIAL_CASES:
+      {
+	struct basilysspecial_st *src = (void *) p;
+	src->mark = 1;
+	break;
+      }
+    case OBMAG_MAPOBJECTS:
+      {
+	struct basilysmapobjects_st *src = (void *) p;
+	int siz, ix;
+	if (!src->entab)
+	  break;
+	siz = basilys_primtab[src->lenix];
+	gcc_assert (siz > 0);
+	if (basilys_is_young (src->entab))
+	  {
+	    struct entryobjectsbasilys_st *newtab =
+	      ggc_alloc_cleared (siz *
+				 sizeof (struct entryobjectsbasilys_st));
+	    memcpy (newtab, src->entab,
+		    siz * sizeof (struct entryobjectsbasilys_st));
+	    src->entab = newtab;
+	  }
+	for (ix = 0; ix < siz; ix++)
+	  {
+	    basilysobject_ptr_t at = src->entab[ix].e_at;
+	    if (!at || at == (void *) 1)
+	      {
+		src->entab[ix].e_va = NULL;
+		continue;
+	      }
+	    FORWARDED (at);
+	    src->entab[ix].e_at = at;
+	    FORWARDED (src->entab[ix].e_va);
+	  }
+	break;
+      }
+    case OBMAG_MAPTREES:
+      {
+	struct basilysmaptrees_st *src = (void *) p;
+	int ix, siz;
+	if (!src->entab)
+	  break;
+	siz = basilys_primtab[src->lenix];
+	gcc_assert (siz > 0);
+	if (basilys_is_young (src->entab))
+	  {
+	    struct entrytreesbasilys_st *newtab =
+	      ggc_alloc_cleared (siz * sizeof (struct entrytreesbasilys_st));
+	    memcpy (newtab, src->entab,
+		    siz * sizeof (struct entrytreesbasilys_st));
+	    src->entab = newtab;
+	  }
+	for (ix = 0; ix < siz; ix++)
+	  {
+	    tree at = src->entab[ix].e_at;
+	    if (!at || at == (void *) 1)
+	      {
+		src->entab[ix].e_va = NULL;
+		continue;
+	      }
+	    FORWARDED (src->entab[ix].e_va);
+	  }
+	break;
+      }
+    case OBMAG_MAPSTRINGS:
+      {
+	struct basilysmapstrings_st *src = (void *) p;
+	int ix, siz;
+	if (!src->entab)
+	  break;
+	siz = basilys_primtab[src->lenix];
+	gcc_assert (siz > 0);
+	if (basilys_is_young (src->entab))
+	  {
+	    struct entrystringsbasilys_st *newtab
+	      =
+	      ggc_alloc_cleared (siz *
+				 sizeof (struct entrystringsbasilys_st));
+	    memcpy (newtab, src->entab,
+		    siz * sizeof (struct entrystringsbasilys_st));
+	    src->entab = newtab;
+	  }
+	for (ix = 0; ix < siz; ix++)
+	  {
+	    char *at = src->entab[ix].e_at;
+	    if (!at || at == (void *) 1)
+	      {
+		src->entab[ix].e_va = NULL;
+		continue;
+	      }
+	    if (basilys_is_young (at))
+	      src->entab[ix].e_at = (char *) ggc_strdup (at);
+	    FORWARDED (src->entab[ix].e_va);
+	  }
+	break;
+      }
+    case OBMAG_MAPBASICBLOCKS:
+      {
+	struct basilysmapbasicblocks_st *src = (void *) p;
+	int ix, siz;
+	if (!src->entab)
+	  break;
+	siz = basilys_primtab[src->lenix];
+	gcc_assert (siz > 0);
+	if (basilys_is_young (src->entab))
+	  {
+	    struct entrybasicblocksbasilys_st *newtab
+	      =
+	      ggc_alloc_cleared (siz *
+				 sizeof (struct entrybasicblocksbasilys_st));
+	    memcpy (newtab, src->entab,
+		    siz * sizeof (struct entrybasicblocksbasilys_st));
+	    src->entab = newtab;
+	  }
+	for (ix = 0; ix < siz; ix++)
+	  {
+	    basic_block at = src->entab[ix].e_at;
+	    if (!at || at == (void *) 1)
+	      {
+		src->entab[ix].e_va = NULL;
+		continue;
+	      }
+	    FORWARDED (src->entab[ix].e_va);
+	  }
+	break;
+      }
+    case OBMAG_MAPEDGES:
+      {
+	struct basilysmapedges_st *src = (void *) p;
+	int siz, ix;
+	if (!src->entab)
+	  break;
+	siz = basilys_primtab[src->lenix];
+	gcc_assert (siz > 0);
+	if (basilys_is_young (src->entab))
+	  {
+	    struct entryedgesbasilys_st *newtab
+	      =
+	      ggc_alloc_cleared (siz * sizeof (struct entryedgesbasilys_st));
+	    memcpy (newtab, src->entab,
+		    siz * sizeof (struct entryedgesbasilys_st));
+	    src->entab = newtab;
+	  }
+	for (ix = 0; ix < siz; ix++)
+	  {
+	    edge at = src->entab[ix].e_at;
+	    if (!at || at == (void *) 1)
+	      {
+		src->entab[ix].e_va = NULL;
+		continue;
+	      }
+	    FORWARDED (src->entab[ix].e_va);
+	  }
+	break;
+      }
+    case OBMAG_MIXINT:
+      {
+	struct basilysmixint_st *src = (void *) p;
+	FORWARDED (src->ptrval);
+	break;
+      }
+    case OBMAG_STRBUF:
+      {
+	struct basilysstrbuf_st *src = (void *) p;
+	char *oldbufzn = src->bufzn;
+	if (basilys_is_young (oldbufzn))
+	  {
+	    int bsiz = basilys_primtab[src->buflenix];
+	    if (bsiz > 0)
+	      {
+		char *newbufzn = ggc_alloc_cleared (bsiz + 1);
+		memcpy (newbufzn, oldbufzn, bsiz);
+		src->bufzn = newbufzn;
+		memset (oldbufzn, 0, bsiz);
+	      }
+	    else
+	      src->bufzn = NULL;
+	  }
+	break;
+      }
+    case OBMAG_INT:
+    case OBMAG_REAL:
+    case OBMAG_STRING:
+    case OBMAG_TREE:
+    case OBMAG_BASICBLOCK:
+    case OBMAG_EDGE:
+      break;
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+
+
+
+
+/** array of about 190 primes gotten by shell command 
+    primes 3 2000000000 | awk '($1>p+p/8){print $1, ","; p=$1}'  **/
+const long basilys_primtab[256] = {
+  0,				/* the first entry indexed #0 is 0 to never be used */
+  3, 5, 7, 11, 13, 17, 23, 29, 37, 43, 53, 61, 71, 83, 97, 113,
+  131, 149, 173, 197, 223, 251, 283, 331, 373, 421, 479, 541,
+  613, 691, 787, 887, 1009, 1151, 1297, 1471, 1657, 1867, 2111,
+  2377, 2677, 3019, 3407, 3833, 4327, 4871, 5483, 6173, 6947,
+  7817, 8803, 9907, 11149, 12547, 14143, 15913, 17903, 20143,
+  22669, 25523, 28723, 32321, 36373, 40927, 46049, 51817,
+  58309, 65599, 73819, 83047, 93463, 105167, 118343, 133153,
+  149803, 168533, 189613, 213319, 239999, 270001, 303767,
+  341743, 384469, 432539, 486617, 547453, 615887, 692893,
+  779507, 876947, 986567, 1109891, 1248631, 1404721, 1580339,
+  1777891, 2000143, 2250163, 2531443, 2847893, 3203909,
+  3604417, 4054987, 4561877, 5132117, 5773679, 6495389,
+  7307323, 8220743, 9248339, 10404403, 11704963, 13168091,
+  14814103, 16665881, 18749123, 21092779, 23729411, 26695609,
+  30032573, 33786659, 38010019, 42761287, 48106453, 54119761,
+  60884741, 68495347, 77057297, 86689469, 97525661, 109716379,
+  123430961, 138859837, 156217333, 175744531, 197712607,
+  222426683, 250230023, 281508827, 316697431, 356284619,
+  400820209, 450922753, 507288107, 570699121, 642036517,
+  722291083, 812577517, 914149741,
+#if HOST_BITS_PER_LONG >= 64
+  1028418463, 1156970821, 1301592203,
+  1464291239, 1647327679, 1853243677, 2084899139, 2345511541,
+  2638700497, 2968538081, 3339605383, 3757056091, 4226688133,
+  4755024167, 5349402193, 6018077509, 6770337239, 7616629399,
+  8568708139, 9639796667, 10844771263, 12200367671,
+  13725413633, 15441090347, 17371226651, 19542629983,
+  21985458749, 24733641113, 27825346259, 31303514549,
+  35216453869, 39618510629, 44570824481, 50142177559,
+#endif
+  0, 0
+};
+
+/* index of entry to get or add an attribute in an mapobject (or -1 on error) */
+static inline int
+unsafe_index_mapobject (struct entryobjectsbasilys_st *tab,
+			basilysobject_ptr_t attr, int siz)
+{
+  int da = 0, ix = 0, frix = -1;
+  unsigned h = 0;
+  if (!tab)
+    return -1;
+  da = attr->obj_class->object_magic;
+  if (da == OBMAG_OBJECT)
+    h = ((struct basilysobject_st *) attr)->obj_hash;
+  else
+    return -1;
+  h = h % siz;
+  for (ix = h; ix < siz; ix++)
+    {
+      basilysobject_ptr_t curat = tab[ix].e_at;
+      if (curat == attr)
+	return ix;
+      else if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+    }
+  for (ix = 0; ix < (int) h; ix++)
+    {
+      basilysobject_ptr_t curat = tab[ix].e_at;
+      if (curat == attr)
+	return ix;
+      else if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+    }
+  return -1;			/* entirely full, should not happen */
+}
+
+
+basilys_ptr_t
+basilysgc_new_int (basilysobject_ptr_t discr_p, long num)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define newint curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define int_newint ((struct basilysint_st*)(newint))
+  newint = NULL;
+  discrv = (void *) discr_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_INT)
+    goto end;
+  newint = basilysgc_allocate (sizeof (struct basilysint_st), 0);
+  int_newint->discr = object_discrv;
+  int_newint->val = num;
+end:
+  BASILYS_EXITFRAME ();
+  return newint;
+#undef newint
+#undef discrv
+#undef int_newint
+#undef object_discrv
+}
+
+
+basilys_ptr_t
+basilysgc_new_mixint (basilysobject_ptr_t discr_p,
+		      basilys_ptr_t val_p, long num)
+{
+  BASILYS_ENTERFRAME (3, NULL);
+#define newmix  curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define valv    curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mix_newmix ((struct basilysmixint_st*)(newmix))
+  newmix = NULL;
+  discrv = (void *) discr_p;
+  valv = val_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MIXINT)
+    goto end;
+  newmix = basilysgc_allocate (sizeof (struct basilysmixint_st), 0);
+  mix_newmix->discr = object_discrv;
+  mix_newmix->intval = num;
+  mix_newmix->ptrval = valv;
+end:
+  BASILYS_EXITFRAME ();
+  return newmix;
+#undef newmix
+#undef valv
+#undef discrv
+#undef mix_newmix
+#undef object_discrv
+}
+
+
+/* allocate a new routine object of given DISCR and of length LEN,
+   with a DESCR-iptive string a a PROC-edure */
+basilysroutine_ptr_t
+basilysgc_new_routine (basilysobject_ptr_t discr_p,
+		       unsigned len, const char *descr,
+		       basilysroutfun_t * proc)
+{
+  union
+  {
+    long fad[1 + sizeof (basilysroutfun_t *) / sizeof (long)];
+    basilysroutfun_t *fproc;
+  } un;
+  BASILYS_ENTERFRAME (2, NULL);
+#define newroutv curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define obj_discrv ((basilysobject_ptr_t)(discrv))
+#define rou_newroutv ((basilysroutine_ptr_t)(newroutv))
+  newroutv = NULL;
+  discrv = discr_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT
+      || obj_discrv->object_magic != OBMAG_ROUTINE || !descr || !descr[0]
+      || !proc || len > BASILYS_MAXLEN)
+    goto end;
+  newroutv =
+    basilysgc_allocate (sizeof (struct basilysroutine_st),
+			len * sizeof (void *));
+  rou_newroutv->discr = discrv;
+  rou_newroutv->nbval = len;
+  memset (&un, 0, sizeof (un));
+  un.fproc = proc;
+  memcpy (rou_newroutv->routaddr, un.fad, sizeof (rou_newroutv->routaddr));
+  strncpy (rou_newroutv->routdescr, descr, BASILYS_ROUTDESCR_LEN - 1);
+  rou_newroutv->routdescr[BASILYS_ROUTDESCR_LEN - 1] = (char) 0;
+end:
+  BASILYS_EXITFRAME ();
+  return newroutv;
+#undef newroutv
+#undef discrv
+#undef obj_discrv
+#undef rou_newroutv
+}
+
+basilysclosure_ptr_t
+basilysgc_new_closure (basilysobject_ptr_t discr_p,
+		       basilysroutine_ptr_t rout_p, unsigned len)
+{
+  BASILYS_ENTERFRAME (3, NULL);
+#define newclosv  curfram__.varptr[0]
+#define discrv    curfram__.varptr[1]
+#define routv     curfram__.varptr[2]
+#define clo_newclosv ((basilysclosure_ptr_t)(newclosv))
+#define obj_discrv   ((basilysobject_ptr_t)(discrv))
+#define rou_routv    ((basilysroutine_ptr_t)(routv))
+  discrv = discr_p;
+  routv = rout_p;
+  newclosv = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT
+      || obj_discrv->object_magic != OBMAG_CLOSURE
+      || basilys_magic_discr (routv) != OBMAG_ROUTINE || len > BASILYS_MAXLEN)
+    goto end;
+  newclosv =
+    basilysgc_allocate (sizeof (struct basilysclosure_st),
+			sizeof (void *) * len);
+  clo_newclosv->discr = discrv;
+  clo_newclosv->rout = routv;
+  clo_newclosv->nbval = len;
+end:
+  BASILYS_EXITFRAME ();
+  return newclosv;
+#undef newclosv
+#undef discrv
+#undef routv
+#undef clo_newclosv
+#undef obj_discrv
+#undef rou_routv
+}
+
+
+
+struct basilysstrbuf_st *
+basilysgc_new_strbuf (basilysobject_ptr_t discr_p, const char *str)
+{
+  int slen = 0, blen = 0, ix = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define newbufv  curfram__.varptr[0]
+#define discrv   curfram__.varptr[1]
+#define buf_newbufv ((struct basilysstrbuf_st*)(newbufv))
+  discrv = discr_p;
+  newbufv = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (((basilysobject_ptr_t) (discrv))->object_magic != OBMAG_STRBUF)
+    goto end;
+  if (str)
+    slen = strlen (str);
+  gcc_assert (slen < BASILYS_MAXLEN);
+  slen += slen / 5 + 40;
+  for (ix = 2; (blen = basilys_primtab[ix]) != 0 && blen < slen; ix++);
+  gcc_assert (blen != 0);
+  newbufv =
+    basilysgc_allocate (offsetof
+			(struct basilysstrbuf_st, buf_space), blen + 1);
+  buf_newbufv->discr = discrv;
+  buf_newbufv->bufzn = buf_newbufv->buf_space;
+  buf_newbufv->buflenix = ix;
+  buf_newbufv->bufstart = 0;
+  if (str)
+    {
+      strcpy (buf_newbufv->bufzn, str);
+      buf_newbufv->bufend = strlen (str);
+    }
+  else
+    buf_newbufv->bufend = 0;
+end:
+  BASILYS_EXITFRAME ();
+  return newbufv;
+#undef newbufv
+#undef discrv
+#undef buf_newbufv
+}
+
+
+void
+basilysgc_add_strbuf_raw (struct basilysstrbuf_st *strbuf_p, const char *str)
+{
+#ifdef ENABLE_CHECKING
+  static long addcount;
+#endif
+  int slen = 0, blen = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define strbufv  curfram__.varptr[0]
+#define buf_strbufv  ((struct basilysstrbuf_st*)(strbufv))
+  strbufv = strbuf_p;
+  if (!str)
+    goto end;
+  if (basilys_magic_discr (strbufv) != OBMAG_STRBUF)
+    goto end;
+  gcc_assert (!basilys_is_young ((void *) (char *) str));
+  slen = strlen (str);
+  blen = basilys_primtab[buf_strbufv->buflenix];
+  gcc_assert (blen > 0);
+#ifdef ENABLE_CHECKING
+  addcount++;
+#endif
+  gcc_assert (buf_strbufv->bufstart <= buf_strbufv->bufend
+	      && buf_strbufv->bufend < (unsigned) blen);
+  if ((int) buf_strbufv->bufend + slen + 2 < blen)
+    {				/* simple case, just copy at end */
+      strcpy (buf_strbufv->bufzn + buf_strbufv->bufend, str);
+      buf_strbufv->bufend += slen;
+      buf_strbufv->bufzn[buf_strbufv->bufend] = 0;
+    }
+  else
+    if ((int) buf_strbufv->bufstart > (int) 0
+	&& (int) buf_strbufv->bufend -
+	(int) buf_strbufv->bufstart + (int) slen + 2 < (int) blen)
+    {				/* should move the buffer to fit */
+      int siz = buf_strbufv->bufend - buf_strbufv->bufstart;
+      gcc_assert (siz > 0);
+      memmove (buf_strbufv->bufzn,
+	       buf_strbufv->bufzn + buf_strbufv->bufstart, siz);
+      buf_strbufv->bufstart = 0;
+      strcpy (buf_strbufv->bufzn + siz, str);
+      buf_strbufv->bufend = siz + slen;
+      buf_strbufv->bufzn[buf_strbufv->bufend] = 0;
+    }
+  else
+    {				/* should grow the buffer to fit */
+      int siz = buf_strbufv->bufend - buf_strbufv->bufstart;
+      int newsiz = (siz + slen + 50 + siz / 8) | 0x1f;
+      int newix = 0, newblen = 0;
+      char *newb = NULL;
+      int oldblen = basilys_primtab[buf_strbufv->buflenix];
+      for (newix = buf_strbufv->buflenix + 1;
+	   (newblen = basilys_primtab[newix]) != 0
+	   && newblen < newsiz; newix++);
+      gcc_assert (newblen >= newsiz);
+      gcc_assert (siz >= 0);
+      if (newblen > BASILYS_MAXLEN)
+	fatal_error ("strbuf overflow to %d bytes", newblen);
+      /* the newly grown buffer is allocated in young memory if the
+         previous was young, or in old memory if it was already old */
+      if (basilys_is_young (buf_strbufv->bufzn))
+	{
+	  newb = basilysgc_allocate (newblen + 1, 0);
+	  memcpy (newb, buf_strbufv->bufzn + buf_strbufv->bufstart, siz);
+	  strcpy (newb + siz, str);
+	  memset (buf_strbufv->bufzn, 0, oldblen);
+	  buf_strbufv->bufzn = newb;
+	}
+      else
+	{
+	  newb = ggc_alloc_cleared (newblen + 1);
+	  memcpy (newb, buf_strbufv->bufzn + buf_strbufv->bufstart, siz);
+	  strcpy (newb + siz, str);
+	  memset (buf_strbufv->bufzn, 0, oldblen);
+	  ggc_free (buf_strbufv->bufzn);
+	  buf_strbufv->bufzn = newb;
+	}
+      buf_strbufv->buflenix = newix;
+      buf_strbufv->bufstart = 0;
+      buf_strbufv->bufend = siz + slen;
+      buf_strbufv->bufzn[buf_strbufv->bufend] = 0;
+      /* touch the buffer so that it will be scanned if not young */
+      basilysgc_touch (strbufv);
+    }
+end:
+  BASILYS_EXITFRAME ();
+#undef strbufv
+#undef buf_strbufv
+}
+
+void
+basilysgc_add_strbuf (struct basilysstrbuf_st *strbuf_p, const char *str)
+{
+  char sbuf[80];
+  char *cstr = NULL;
+  int slen = 0;
+  if (str)
+    slen = strlen (str);
+  if (slen <= 0)
+    return;
+  if (slen < (int) sizeof (sbuf) - 1)
+    {
+      memset (sbuf, 0, sizeof (sbuf));
+      strcpy (sbuf, str);
+      basilysgc_add_strbuf_raw (strbuf_p, sbuf);
+    }
+  else
+    {
+      cstr = xstrdup (str);
+      basilysgc_add_strbuf_raw (strbuf_p, cstr);
+      free (cstr);
+    }
+}
+
+void
+basilysgc_add_strbuf_cstr (struct basilysstrbuf_st *strbuf_p, const char *str)
+{
+  int slen = str ? strlen (str) : 0;
+  const char *ps = NULL;
+  char *pd = NULL;
+  char *cstr = NULL;
+  if (!str || !str[0])
+    return;
+  cstr = xcalloc (slen + 5, 4);
+  pd = cstr;
+  for (ps = str; *ps; ps++)
+    {
+      switch (*ps)
+	{
+#define ADDS(S) strcpy(pd, S); pd+=sizeof(S)-1; break
+	case '\n':
+	  ADDS ("\\n");
+	case '\r':
+	  ADDS ("\\r");
+	case '\t':
+	  ADDS ("\\t");
+	case '\v':
+	  ADDS ("\\v");
+	case '\f':
+	  ADDS ("\\f");
+	case '\'':
+	  ADDS ("\\\'");
+	case '\"':
+	  ADDS ("\\\"");
+	case '\\':
+	  ADDS ("\\\\");
+#undef ADDS
+	default:
+	  if (ISPRINT (*ps))
+	    *(pd++) = *ps;
+	  else
+	    {
+	      sprintf (pd, "\\%03o", (*ps) & 0xff);
+	      pd += 4;
+	    }
+	}
+    };
+  basilysgc_add_strbuf_raw (strbuf_p, cstr);
+  free (cstr);
+}
+
+
+void
+basilysgc_add_strbuf_ccomment (struct basilysstrbuf_st
+			       *strbuf_p, const char *str)
+{
+  int slen = str ? strlen (str) : 0;
+  const char *ps = NULL;
+  char *pd = NULL;
+  char *cstr = NULL;
+  if (!str || !str[0])
+    return;
+  cstr = xcalloc (slen + 4, 4);
+  pd = cstr;
+  for (ps = str; *ps; ps++)
+    {
+      if (ps[0] == '/' && ps[1] == '*')
+	{
+	  pd[0] = '/';
+	  pd[1] = '+';
+	  pd += 2;
+	  ps++;
+	}
+      else if (ps[0] == '*' && ps[1] == '/')
+	{
+	  pd[0] = '+';
+	  pd[1] = '/';
+	  pd += 2;
+	  ps++;
+	}
+      else
+	*(pd++) = *ps;
+    };
+  basilysgc_add_strbuf_raw (strbuf_p, cstr);
+  free (cstr);
+}
+
+void
+basilysgc_add_strbuf_cident (struct basilysstrbuf_st
+			     *strbuf_p, const char *str)
+{
+  int slen = str ? strlen (str) : 0;
+  char *dupstr = 0;
+  char *pc = 0;
+  char tinybuf[80];
+  if (!str || !str[0])
+    return;
+  if (slen < (int) sizeof (tinybuf) - 2)
+    {
+      memset (tinybuf, 0, sizeof (tinybuf));
+      if (str)
+	strcpy (tinybuf, str);
+      dupstr = tinybuf;
+    }
+  else
+    {
+      dupstr = xcalloc (slen + 2, 1);
+      if (str)
+	strcpy (dupstr, str);
+    };
+  for (pc = dupstr; *pc; pc++)
+    if (!ISALNUM (*pc))
+      *pc = '_';
+  basilysgc_add_strbuf_raw (strbuf_p, dupstr);
+  if (dupstr && dupstr != tinybuf)
+    free (dupstr);
+}
+
+void
+basilysgc_add_strbuf_cidentprefix (struct basilysstrbuf_st
+				   *strbuf_p, const char *str, int preflen)
+{
+  char *dupstr = 0;
+  char *pc = 0;
+  char tinybuf[80];
+  if (str)
+    {
+      int lenst = strlen (str);
+      if (lenst < preflen)
+	preflen = lenst;
+    }
+  else
+    return;
+  if (preflen >= (int) sizeof (tinybuf) - 1)
+    preflen = sizeof (tinybuf) - 2;
+  if (preflen <= 0)
+    return;
+  memset (tinybuf, 0, sizeof (tinybuf));
+  if (str)
+    strncpy (tinybuf, str, preflen);
+  dupstr = tinybuf;
+  for (pc = dupstr; *pc; pc++)
+    if (!ISALNUM (*pc))
+      *pc = '_';
+  basilysgc_add_strbuf_raw (strbuf_p, dupstr);
+}
+
+
+void
+basilysgc_add_strbuf_hex (struct basilysstrbuf_st *strbuf_p, unsigned long l)
+{
+  if (l == 0UL)
+    basilysgc_add_strbuf_raw (strbuf_p, "0");
+  else
+    {
+      int ix = 0, j = 0;
+      char revbuf[80], thebuf[80];
+      memset (revbuf, 0, sizeof (revbuf));
+      memset (thebuf, 0, sizeof (thebuf));
+      while (ix < (int) sizeof (revbuf) - 1 && l != 0UL)
+	{
+	  unsigned h = l & 15;
+	  l >>= 4;
+	  revbuf[ix++] = "0123456789abcdef"[h];
+	}
+      ix--;
+      for (j = 0; j < (int) sizeof (thebuf) - 1 && ix >= 0; j++, ix--)
+	thebuf[j] = revbuf[ix];
+      basilysgc_add_strbuf_raw (strbuf_p, thebuf);
+    }
+}
+
+
+void
+basilysgc_add_strbuf_dec (struct basilysstrbuf_st *strbuf_p, long l)
+{
+  if (l == 0UL)
+    basilysgc_add_strbuf_raw (strbuf_p, "0");
+  else
+    {
+      int ix = 0, j = 0, neg = 0;
+      char revbuf[96], thebuf[96];
+      memset (revbuf, 0, sizeof (revbuf));
+      memset (thebuf, 0, sizeof (thebuf));
+      if (l < 0)
+	{
+	  l = -l;
+	  neg = 1;
+	};
+      while (ix < (int) sizeof (revbuf) - 1 && l != 0UL)
+	{
+	  unsigned h = l % 10;
+	  l = l / 10;
+	  revbuf[ix++] = "0123456789"[h];
+	}
+      ix--;
+      if (neg)
+	{
+	  thebuf[0] = '-';
+	  j = 1;
+	};
+      for (; j < (int) sizeof (thebuf) - 1 && ix >= 0; j++, ix--)
+	thebuf[j] = revbuf[ix];
+      basilysgc_add_strbuf_raw (strbuf_p, thebuf);
+    }
+}
+
+
+void
+basilysgc_strbuf_printf (struct basilysstrbuf_st *strbuf_p,
+			 const char *fmt, ...)
+{
+  char *cstr = NULL;
+  va_list ap;
+  int l = 0;
+  static char tinybuf[80];
+  memset (tinybuf, 0, sizeof (tinybuf));
+  va_start (ap, fmt);
+  l = vsnprintf (tinybuf, sizeof (tinybuf) - 1, fmt, ap);
+  va_end (ap);
+  if (l < (int) sizeof (tinybuf) - 3)
+    {
+      basilysgc_add_strbuf_raw (strbuf_p, tinybuf);
+      return;
+    }
+  va_start (ap, fmt);
+  vasprintf (&cstr, fmt, ap);
+  va_end (ap);
+  basilysgc_add_strbuf_raw (strbuf_p, cstr);
+  free (cstr);
+}
+
+
+/* add safely into STRBUF either a space or an indented newline if the current line is bigger than the threshold */
+void
+basilysgc_strbuf_add_indent (struct basilysstrbuf_st
+			     *strbuf_p, int depth, int linethresh)
+{
+  int llln = 0;			/* last line length */
+  if (!strbuf_p || basilys_magic_discr ((void *) strbuf_p) != OBMAG_STRBUF)
+    return;
+  if (linethresh > 0 && linethresh < 40)
+    linethresh = 40;
+  /* compute the last line length llln */
+  {
+    char *bs = 0, *be = 0, *nl = 0;
+    bs = strbuf_p->bufzn + strbuf_p->bufstart;
+    be = strbuf_p->bufzn + strbuf_p->bufend;
+    for (nl = be - 1; nl > bs && *nl && *nl != '\n'; nl--);
+    llln = be - nl;
+    gcc_assert (llln >= 0);
+  }
+  if (linethresh > 0 && llln < linethresh)
+    basilysgc_add_strbuf_raw (strbuf_p, " ");
+  else
+    {
+      int nbsp = depth;
+      static const char spaces32[] = "                                ";
+      basilysgc_add_strbuf_raw (strbuf_p, "\n");
+      if (nbsp < 0)
+	nbsp = 0;
+      if (nbsp > 0 && nbsp % 32 != 0)
+	basilysgc_add_strbuf_raw (strbuf_p, spaces32 + (32 - nbsp % 32));
+    }
+}
+
+
+
+
+/***************/
+
+basilysobject_ptr_t
+basilysgc_new_raw_object (basilysobject_ptr_t klass_p, unsigned len)
+{
+  unsigned h = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define newobjv   curfram__.varptr[0]
+#define klassv    curfram__.varptr[1]
+#define obj_newobjv  ((basilysobject_ptr_t)(newobjv))
+#define obj_klassv   ((basilysobject_ptr_t)(klassv))
+  newobjv = NULL;
+  klassv = klass_p;
+  if (basilys_magic_discr (klassv) != OBMAG_OBJECT
+      || obj_klassv->object_magic != OBMAG_OBJECT || len >= SHRT_MAX)
+    goto end;
+  newobjv =
+    basilysgc_allocate (offsetof
+			(struct basilysobject_st,
+			 obj__tabfields), len * sizeof (void *));
+  obj_newobjv->obj_class = klassv;
+  do
+    {
+      h = basilys_lrand () & BASILYS_MAXHASH;
+    }
+  while (h == 0);
+  obj_newobjv->obj_hash = h;
+  obj_newobjv->obj_len = len;
+  if (len > 0)
+    obj_newobjv->obj_vartab = obj_newobjv->obj__tabfields;
+end:
+  BASILYS_EXITFRAME ();
+  return newobjv;
+#undef newobjv
+#undef klassv
+#undef obj_newobjv
+#undef obj_klassv
+}
+
+
+/* allocate a new multiple of given DISCR & length LEN */
+basilys_ptr_t
+basilysgc_new_multiple (basilysobject_ptr_t discr_p, unsigned len)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  newmul = NULL;
+  gcc_assert (len < BASILYS_MAXLEN);
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * len);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = len;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discr
+#undef mult_newmul
+#undef object_discrv
+}
+
+
+void
+basilysgc_multiple_put_nth (basilysmultiple_ptr_t mul_p,
+			    int n, basilys_ptr_t val_p)
+{
+  int ln = 0;
+  BASILYS_ENTERFRAME (3, NULL);
+#define mulv    curfram__.varptr[0]
+#define mult_mulv ((struct basilysmultiple_st*)(mulv))
+#define discrv  curfram__.varptr[1]
+#define valv    curfram__.varptr[2]
+  mulv = mul_p;
+  valv = val_p;
+  if (!basilys_magic_discr (mulv) == OBMAG_MULTIPLE)
+    goto end;
+  ln = mult_mulv->nbval;
+  if (n < 0)
+    n += ln;
+  if (n >= 0 && n < ln)
+    {
+      mult_mulv->tabval[n] = valv;
+      basilysgc_touch_dest (mulv, valv);
+    }
+end:
+  BASILYS_EXITFRAME ();
+#undef mulv
+#undef mult_mulv
+#undef discrv
+#undef valv
+}
+
+/* allocate a new box of given DISCR & content VAL */
+basilys_ptr_t
+basilysgc_new_box (basilysobject_ptr_t discr_p, basilys_ptr_t val_p)
+{
+  BASILYS_ENTERFRAME (3, NULL);
+#define boxv curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define valv   curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+  discrv = (void *) discr_p;
+  valv = (void *) val_p;
+  boxv = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_BOX)
+    goto end;
+  boxv = basilysgc_allocate (sizeof (struct basilysbox_st), 0);
+  ((struct basilysbox_st *) (boxv))->discr = discrv;
+  ((struct basilysbox_st *) (boxv))->val = valv;
+end:
+  BASILYS_EXITFRAME ();
+  return boxv;
+#undef boxv
+#undef discr
+#undef valv
+#undef object_discrv
+}
+
+/* put inside a box */
+void
+basilysgc_box_put (basilys_ptr_t box_p, basilys_ptr_t val_p)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define boxv curfram__.varptr[0]
+#define valv   curfram__.varptr[1]
+  boxv = box_p;
+  valv = val_p;
+  if (basilys_magic_discr (boxv) != OBMAG_BOX)
+    goto end;
+  ((basilysbox_ptr_t) boxv)->val = valv;
+  basilysgc_touch_dest (boxv, valv);
+end:
+  BASILYS_EXITFRAME ();
+#undef boxv
+#undef valv
+}
+
+
+/* allocate a multiple of arity 1 */
+basilys_ptr_t
+basilysgc_new_mult1 (basilysobject_ptr_t discr_p, basilys_ptr_t v0_p)
+{
+  BASILYS_ENTERFRAME (3, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define v0   curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  v0 = v0_p;
+  newmul = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * 1);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = 1;
+  mult_newmul->tabval[0] = v0;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discr
+#undef v0
+#undef mult_newmul
+#undef object_discrv
+}
+
+basilys_ptr_t
+basilysgc_new_mult2 (basilysobject_ptr_t discr_p,
+		     basilys_ptr_t v0_p, basilys_ptr_t v1_p)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define v0   curfram__.varptr[2]
+#define v1   curfram__.varptr[3]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  v0 = v0_p;
+  v1 = v1_p;
+  newmul = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * 2);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = 2;
+  mult_newmul->tabval[0] = v0;
+  mult_newmul->tabval[1] = v1;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discr
+#undef v0
+#undef v1
+#undef mult_newmul
+#undef object_discrv
+}
+
+basilys_ptr_t
+basilysgc_new_mult3 (basilysobject_ptr_t discr_p,
+		     basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+		     basilys_ptr_t v2_p)
+{
+  BASILYS_ENTERFRAME (5, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define v0   curfram__.varptr[2]
+#define v1   curfram__.varptr[3]
+#define v2   curfram__.varptr[4]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  v0 = v0_p;
+  v1 = v1_p;
+  v2 = v2_p;
+  newmul = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * 3);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = 3;
+  mult_newmul->tabval[0] = v0;
+  mult_newmul->tabval[1] = v1;
+  mult_newmul->tabval[2] = v2;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discrv
+#undef v0
+#undef v1
+#undef v2
+#undef mult_newmul
+#undef object_discrv
+}
+
+basilys_ptr_t
+basilysgc_new_mult4 (basilysobject_ptr_t discr_p,
+		     basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+		     basilys_ptr_t v2_p, basilys_ptr_t v3_p)
+{
+  BASILYS_ENTERFRAME (6, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define v0   curfram__.varptr[2]
+#define v1   curfram__.varptr[3]
+#define v2   curfram__.varptr[4]
+#define v3   curfram__.varptr[5]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  v0 = v0_p;
+  v1 = v1_p;
+  v2 = v2_p;
+  v3 = v3_p;
+  newmul = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * 4);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = 4;
+  mult_newmul->tabval[0] = v0;
+  mult_newmul->tabval[1] = v1;
+  mult_newmul->tabval[2] = v2;
+  mult_newmul->tabval[3] = v3;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discrv
+#undef v0
+#undef v1
+#undef v2
+#undef v3
+#undef mult_newmul
+#undef object_discrv
+}
+
+basilys_ptr_t
+basilysgc_new_mult5 (basilysobject_ptr_t discr_p,
+		     basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+		     basilys_ptr_t v2_p, basilys_ptr_t v3_p,
+		     basilys_ptr_t v4_p)
+{
+  BASILYS_ENTERFRAME (7, NULL);
+#define newmul curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define v0   curfram__.varptr[2]
+#define v1   curfram__.varptr[3]
+#define v2   curfram__.varptr[4]
+#define v3   curfram__.varptr[5]
+#define v4   curfram__.varptr[6]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mult_newmul ((struct basilysmultiple_st*)(newmul))
+  discrv = (void *) discr_p;
+  v0 = v0_p;
+  v1 = v1_p;
+  v2 = v2_p;
+  v3 = v3_p;
+  v4 = v4_p;
+  newmul = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MULTIPLE)
+    goto end;
+  newmul =
+    basilysgc_allocate (sizeof (struct basilysmultiple_st),
+			sizeof (void *) * 5);
+  mult_newmul->discr = object_discrv;
+  mult_newmul->nbval = 5;
+  mult_newmul->tabval[0] = v0;
+  mult_newmul->tabval[1] = v1;
+  mult_newmul->tabval[2] = v2;
+  mult_newmul->tabval[3] = v3;
+  mult_newmul->tabval[4] = v4;
+end:
+  BASILYS_EXITFRAME ();
+  return newmul;
+#undef newmul
+#undef discrv
+#undef v0
+#undef v1
+#undef v2
+#undef v3
+#undef v4
+#undef mult_newmul
+#undef object_discrv
+}
+
+
+basilys_ptr_t
+basilysgc_new_list (basilysobject_ptr_t discr_p)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv curfram__.varptr[0]
+#define newlist curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define list_newlist ((struct basilyslist_st*)(newlist))
+  discrv = (void *) discr_p;
+  newlist = NULL;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_LIST)
+    goto end;
+  newlist = basilysgc_allocate (sizeof (struct basilyslist_st), 0);
+  list_newlist->discr = object_discrv;
+  list_newlist->first = NULL;
+  list_newlist->last = NULL;
+end:
+  BASILYS_EXITFRAME ();
+  return newlist;
+#undef newlist
+#undef discrv
+#undef list_newlist
+#undef object_discrv
+}
+
+/* allocate a pair of given head and tail */
+basilys_ptr_t
+basilysgc_new_pair (basilysobject_ptr_t discr_p, void *head_p, void *tail_p)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define pairv   curfram__.varptr[0]
+#define discrv  curfram__.varptr[1]
+#define headv   curfram__.varptr[2]
+#define tailv   curfram__.varptr[3]
+  discrv = discr_p;
+  headv = head_p;
+  tailv = tail_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT
+      || ((basilysobject_ptr_t) (discrv))->object_magic != OBMAG_PAIR)
+    goto end;
+  if (basilys_magic_discr (tailv) != OBMAG_PAIR)
+    tailv = NULL;
+  pairv = basilysgc_allocate (sizeof (struct basilyspair_st), 0);
+  ((struct basilyspair_st *) (pairv))->discr = discrv;
+  ((struct basilyspair_st *) (pairv))->hd = headv;
+  ((struct basilyspair_st *) (pairv))->tl = tailv;
+end:
+  BASILYS_EXITFRAME ();
+  return pairv;
+#undef pairv
+#undef headv
+#undef tailv
+#undef discrv
+}
+
+/* change the head of a pair */
+void
+basilysgc_pair_set_head (basilys_ptr_t pair_p, void *head_p)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define pairv   curfram__.varptr[0]
+#define headv   curfram__.varptr[1]
+  pairv = pair_p;
+  headv = head_p;
+  if (basilys_magic_discr (pairv) != OBMAG_PAIR)
+    goto end;
+  ((struct basilyspair_st *) pairv)->hd = headv;
+  basilysgc_touch_dest (pairv, headv);
+end:
+  BASILYS_EXITFRAME ();
+#undef pairv
+#undef headv
+}
+
+
+void
+basilysgc_append_list (basilys_ptr_t list_p, basilys_ptr_t valu_p)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define list curfram__.varptr[0]
+#define valu curfram__.varptr[1]
+#define pairv curfram__.varptr[2]
+#define lastv curfram__.varptr[3]
+#define pai_pairv ((struct basilyspair_st*)(pairv))
+#define list_list ((struct basilyslist_st*)(list))
+  list = list_p;
+  valu = valu_p;
+  if (basilys_magic_discr (list) != OBMAG_LIST || !BASILYSGOB (DISCR_PAIR))
+    goto end;
+  pairv = basilysgc_allocate (sizeof (struct basilyspair_st), 0);
+  pai_pairv->discr = BASILYSGOB (DISCR_PAIR);
+  pai_pairv->hd = valu;
+  pai_pairv->tl = NULL;
+  gcc_assert (basilys_magic_discr (pairv) == OBMAG_PAIR);
+  lastv = list_list->last;
+  if (basilys_magic_discr ((basilys_ptr_t) lastv) == OBMAG_PAIR)
+    {
+      gcc_assert (((struct basilyspair_st *) lastv)->tl == NULL);
+      ((struct basilyspair_st *) lastv)->tl = pairv;
+      basilysgc_touch_dest (lastv, pairv);
+    }
+  else
+    list_list->first = pairv;
+  list_list->last = pairv;
+  basilysgc_touch_dest (list, pairv);
+end:
+  BASILYS_EXITFRAME ();
+#undef list
+#undef valu
+#undef list_list
+#undef pairv
+#undef pai_pairv
+#undef lastv
+}
+
+void
+basilysgc_prepend_list (basilys_ptr_t list_p, basilys_ptr_t valu_p)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define list curfram__.varptr[0]
+#define valu curfram__.varptr[1]
+#define pairv curfram__.varptr[2]
+#define firstv curfram__.varptr[3]
+#define pai_pairv ((struct basilyspair_st*)(pairv))
+#define list_list ((struct basilyslist_st*)(list))
+  list = list_p;
+  valu = valu_p;
+  if (basilys_magic_discr (list) != OBMAG_LIST || !BASILYSGOB (DISCR_PAIR))
+    goto end;
+  pairv = basilysgc_allocate (sizeof (struct basilyspair_st), 0);
+  pai_pairv->discr = BASILYSGOB (DISCR_PAIR);
+  pai_pairv->hd = valu;
+  pai_pairv->tl = NULL;
+  gcc_assert (basilys_magic_discr (pairv) == OBMAG_PAIR);
+  firstv = (basilys_ptr_t) (list_list->first);
+  if (basilys_magic_discr (firstv) == OBMAG_PAIR)
+    {
+      pai_pairv->tl = firstv;
+      basilysgc_touch_dest (pairv, firstv);
+    }
+  else
+    list_list->last = pairv;
+  list_list->first = pairv;
+  basilysgc_touch_dest (list, pairv);
+end:
+  BASILYS_EXITFRAME ();
+#undef list
+#undef valu
+#undef list_list
+#undef pairv
+#undef pai_pairv
+}
+
+
+basilys_ptr_t
+basilysgc_popfirst_list (basilys_ptr_t list_p)
+{
+  BASILYS_ENTERFRAME (3, NULL);
+#define list curfram__.varptr[0]
+#define valu curfram__.varptr[1]
+#define pairv curfram__.varptr[2]
+#define pai_pairv ((struct basilyspair_st*)(pairv))
+#define list_list ((struct basilyslist_st*)(list))
+  list = list_p;
+  if (basilys_magic_discr (list) != OBMAG_LIST)
+    goto end;
+  pairv = list_list->first;
+  if (basilys_magic_discr ((basilys_ptr_t) pairv) != OBMAG_PAIR)
+    goto end;
+  if (list_list->last == pairv)
+    {
+      valu = pai_pairv->hd;
+      list_list->first = NULL;
+      list_list->last = NULL;
+    }
+  else
+    {
+      valu = pai_pairv->hd;
+      list_list->first = pai_pairv->tl;
+    }
+  basilysgc_touch (list);
+end:
+  BASILYS_EXITFRAME ();
+  return valu;
+#undef list
+#undef value
+#undef list_list
+#undef pairv
+#undef pai_pairv
+}				/* enf of popfirst */
+
+
+/* return the length of a list or -1 iff non list */
+int
+basilys_list_length (basilys_ptr_t list_p)
+{
+  struct basilyspair_st *pair = NULL;
+  int ln = 0;
+  if (basilys_magic_discr (list_p) != OBMAG_LIST)
+    return -1;
+  for (pair = ((struct basilyslist_st *) list_p)->first;
+       basilys_magic_discr ((basilys_ptr_t) pair) ==
+       OBMAG_PAIR; pair = (struct basilyspair_st *) (pair->tl))
+    ln++;
+  return ln;
+}
+
+
+/* allocate a new empty mapobjects */
+basilys_ptr_t
+basilysgc_new_mapobjects (basilysobject_ptr_t discr_p, unsigned len)
+{
+  int maplen = 0;
+  int lenix = 0, primlen = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv curfram__.varptr[0]
+#define newmapv curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mapobject_newmapv ((struct basilysmapobjects_st*)(newmapv))
+  discrv = discr_p;
+  if (!discrv || object_discrv->obj_class->object_magic != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MAPOBJECTS)
+    goto end;
+  if (len > 0)
+    {
+      gcc_assert (len < (unsigned) BASILYS_MAXLEN);
+      for (lenix = 1;
+	   (primlen = (int) basilys_primtab[lenix]) != 0
+	   && primlen <= (int) len; lenix++);
+      maplen = primlen;
+    };
+  newmapv =
+    basilysgc_allocate (offsetof
+			(struct basilysmapobjects_st, map_space),
+			maplen * sizeof (struct entryobjectsbasilys_st));
+  mapobject_newmapv->discr = object_discrv;
+  if (len > 0)
+    {
+      mapobject_newmapv->entab = mapobject_newmapv->map_space;
+      mapobject_newmapv->lenix = lenix;
+    };
+end:
+  BASILYS_EXITFRAME ();
+  return newmapv;
+#undef discrv
+#undef newmapv
+#undef object_discrv
+#undef mapobject_newmapv
+}
+
+/* get from a mapobject */
+basilys_ptr_t
+basilys_get_mapobjects (basilysmapobjects_ptr_t mapobject_p,
+			basilysobject_ptr_t attrobject_p)
+{
+  long ix, len;
+  basilys_ptr_t val = NULL;
+  if (!mapobject_p || !attrobject_p
+      || mapobject_p->discr->object_magic != OBMAG_MAPOBJECTS
+      || !mapobject_p->entab
+      || attrobject_p->obj_class->object_magic != OBMAG_OBJECT)
+    return NULL;
+  len = basilys_primtab[mapobject_p->lenix];
+  if (len <= 0)
+    return NULL;
+  ix = unsafe_index_mapobject (mapobject_p->entab, attrobject_p, len);
+  if (ix < 0)
+    return NULL;
+  if (mapobject_p->entab[ix].e_at == attrobject_p)
+    val = mapobject_p->entab[ix].e_va;
+  return val;
+}
+
+void
+basilysgc_put_mapobjects (basilysmapobjects_ptr_t
+			  mapobject_p,
+			  basilysobject_ptr_t attrobject_p,
+			  basilys_ptr_t valu_p)
+{
+  long ix = 0, len = 0, cnt = 0;
+  BASILYS_ENTERFRAME (4, NULL);
+#define discrv curfram__.varptr[0]
+#define mapobjectv curfram__.varptr[1]
+#define attrobjectv curfram__.varptr[2]
+#define valuv curfram__.varptr[3]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define object_attrobjectv ((basilysobject_ptr_t)(attrobjectv))
+#define map_mapobjectv ((basilysmapobjects_ptr_t)(mapobjectv))
+  mapobjectv = mapobject_p;
+  attrobjectv = attrobject_p;
+  valuv = valu_p;
+  if (!mapobjectv || !attrobjectv || !valuv)
+    goto end;
+  discrv = map_mapobjectv->discr;
+  if (!discrv || object_discrv->object_magic != OBMAG_MAPOBJECTS)
+    goto end;
+  discrv = object_attrobjectv->obj_class;
+  if (!discrv || object_discrv->object_magic != OBMAG_OBJECT)
+    goto end;
+  if (!map_mapobjectv->entab)
+    {
+      len = basilys_primtab[1];	/* i.e. 3 */
+      if (basilys_is_young (mapobjectv))
+	map_mapobjectv->entab =
+	  basilysgc_allocate (len *
+			      sizeof (struct entryobjectsbasilys_st), 0);
+      else
+	map_mapobjectv->entab =
+	  ggc_alloc_cleared (len * sizeof (struct entryobjectsbasilys_st));
+      map_mapobjectv->lenix = 1;
+      basilysgc_touch (map_mapobjectv);
+    }
+  else
+    if ((len = basilys_primtab[map_mapobjectv->lenix]) <=
+	(5 * (cnt = map_mapobjectv->count)) / 4 + 1
+	|| (len <= 5 && cnt + 1 >= len))
+    {
+      int ix, newcnt = 0;
+      int newlen = basilys_primtab[map_mapobjectv->lenix + 1];
+      struct entryobjectsbasilys_st *newtab = NULL;
+      struct entryobjectsbasilys_st *oldtab = NULL;
+      if (basilys_is_young (map_mapobjectv->entab))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entryobjectsbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entryobjectsbasilys_st));
+      oldtab = map_mapobjectv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  basilysobject_ptr_t curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mapobject (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in old ggc space */
+	ggc_free (oldtab);
+      map_mapobjectv->entab = newtab;
+      map_mapobjectv->count = newcnt;
+      map_mapobjectv->lenix++;
+      basilysgc_touch (map_mapobjectv);
+      len = newlen;
+    }
+  ix =
+    unsafe_index_mapobject (map_mapobjectv->entab, object_attrobjectv, len);
+  gcc_assert (ix >= 0);
+  if (map_mapobjectv->entab[ix].e_at != attrobjectv)
+    {
+      map_mapobjectv->entab[ix].e_at = attrobjectv;
+      map_mapobjectv->count++;
+    }
+  map_mapobjectv->entab[ix].e_va = valuv;
+  basilysgc_touch_dest (map_mapobjectv, attrobjectv);
+  basilysgc_touch_dest (map_mapobjectv, valuv);
+end:
+  BASILYS_EXITFRAME ();
+#undef discrv
+#undef mapobjectv
+#undef attrobjectv
+#undef valuv
+#undef object_discrv
+#undef object_attrobjectv
+#undef map_mapobjectv
+}
+
+
+basilys_ptr_t
+basilysgc_remove_mapobjects (basilysmapobjects_ptr_t
+			     mapobject_p, basilysobject_ptr_t attrobject_p)
+{
+  long ix = 0, len = 0, cnt = 0;
+  BASILYS_ENTERFRAME (4, NULL);
+#define discrv curfram__.varptr[0]
+#define mapobjectv curfram__.varptr[1]
+#define attrobjectv curfram__.varptr[2]
+#define valuv curfram__.varptr[3]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define object_attrobjectv ((basilysobject_ptr_t)(attrobjectv))
+#define map_mapobjectv ((basilysmapobjects_ptr_t)(mapobjectv))
+  mapobjectv = mapobject_p;
+  attrobjectv = attrobject_p;
+  valuv = NULL;
+  if (!mapobjectv || !attrobjectv)
+    goto end;
+  discrv = map_mapobjectv->discr;
+  if (!discrv || object_discrv->object_magic != OBMAG_MAPOBJECTS)
+    goto end;
+  discrv = object_attrobjectv->obj_class;
+  if (!discrv || object_discrv->object_magic != OBMAG_OBJECT)
+    goto end;
+  if (!map_mapobjectv->entab)
+    goto end;
+  len = basilys_primtab[map_mapobjectv->lenix];
+  if (len <= 0)
+    goto end;
+  ix = unsafe_index_mapobject (map_mapobjectv->entab, attrobject_p, len);
+  if (ix < 0 || map_mapobjectv->entab[ix].e_at != attrobjectv)
+    goto end;
+  map_mapobjectv->entab[ix].e_at = (void *) HTAB_DELETED_ENTRY;
+  valuv = map_mapobjectv->entab[ix].e_va;
+  map_mapobjectv->entab[ix].e_va = NULL;
+  map_mapobjectv->count--;
+  cnt = map_mapobjectv->count;
+  if (len >= 7 && cnt < len / 2 - 2)
+    {
+      int newcnt = 0, newlen = 0, newlenix;
+      struct entryobjectsbasilys_st *oldtab = NULL, *newtab = NULL;
+      for (newlenix = map_mapobjectv->lenix;
+	   (newlen = basilys_primtab[newlenix]) > 2 * cnt + 3; newlenix--);
+      if (newlen >= len)
+	goto end;
+      if (basilys_is_young (map_mapobjectv->entab))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entryobjectsbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entryobjectsbasilys_st));
+      oldtab = map_mapobjectv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  basilysobject_ptr_t curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mapobject (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in old ggc space */
+	ggc_free (oldtab);
+      map_mapobjectv->entab = newtab;
+      map_mapobjectv->count = newcnt;
+      map_mapobjectv->lenix = newlenix;
+    }
+  basilysgc_touch (map_mapobjectv);
+end:
+  BASILYS_EXITFRAME ();
+  return valuv;
+#undef discrv
+#undef mapobjectv
+#undef attrobjectv
+#undef valuv
+#undef object_discrv
+#undef object_attrobjectv
+#undef map_mapobjectv
+}
+
+
+
+/* index of entry to get or add an attribute in an mapstring (or -1 on error) */
+static inline int
+unsafe_index_mapstring (struct entrystringsbasilys_st *tab,
+			const char *attr, int siz)
+{
+  int ix = 0, frix = -1;
+  unsigned h = 0;
+  if (!tab || !attr || siz <= 0)
+    return -1;
+  h = (unsigned) htab_hash_string (attr) & BASILYS_MAXHASH;
+  h = h % siz;
+  for (ix = h; ix < siz; ix++)
+    {
+      const char *curat = tab[ix].e_at;
+      if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+      else if (!strcmp (curat, attr))
+	return ix;
+    }
+  for (ix = 0; ix < (int) h; ix++)
+    {
+      const char *curat = tab[ix].e_at;
+      if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+      else if (!strcmp (curat, attr))
+	return ix;
+    }
+  return -1;			/* entirely full, should not happen */
+}
+
+/* allocate a new empty mapstrings */
+basilys_ptr_t
+basilysgc_new_mapstrings (basilysobject_ptr_t discr_p, unsigned len)
+{
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv curfram__.varptr[0]
+#define newmapv curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define mapstring_newmapv ((struct basilysmapstrings_st*)(newmapv))
+  discrv = discr_p;
+  if (!discrv || object_discrv->obj_class->object_magic != OBMAG_OBJECT)
+    goto end;
+  if (object_discrv->object_magic != OBMAG_MAPSTRINGS)
+    goto end;
+  newmapv = basilysgc_allocate (sizeof (struct basilysmapstrings_st), 0);
+  mapstring_newmapv->discr = object_discrv;
+  if (len > 0)
+    {
+      int lenix, primlen;
+      gcc_assert (len < (unsigned) BASILYS_MAXLEN);
+      for (lenix = 1;
+	   (primlen = (int) basilys_primtab[lenix]) != 0
+	   && primlen <= (int) len; lenix++);
+      /* the newmapv is always young */
+      mapstring_newmapv->entab =
+	basilysgc_allocate (primlen *
+			    sizeof (struct entrystringsbasilys_st), 0);
+      mapstring_newmapv->lenix = lenix;
+      basilysgc_touch_dest (newmapv, mapstring_newmapv->entab);
+    }
+end:
+  BASILYS_EXITFRAME ();
+  return newmapv;
+#undef discrv
+#undef newmapv
+#undef object_discrv
+#undef mapstring_newmapv
+}
+
+
+void
+basilysgc_put_mapstrings (struct basilysmapstrings_st
+			  *mapstring_p, const char *attr,
+			  basilys_ptr_t valu_p)
+{
+  long ix = 0, len = 0, cnt = 0, atlen = 0;
+  char *attrdup = 0;
+  char tinybuf[130];
+  BASILYS_ENTERFRAME (3, NULL);
+#define discrv curfram__.varptr[0]
+#define mapstringv curfram__.varptr[1]
+#define valuv curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define map_mapstringv ((struct basilysmapstrings_st*)(mapstringv))
+  mapstringv = mapstring_p;
+  valuv = valu_p;
+  if (!mapstringv || !attr || !attr[0] || !valuv)
+    goto end;
+  discrv = map_mapstringv->discr;
+  if (!discrv || object_discrv->object_magic != OBMAG_MAPSTRINGS)
+    goto end;
+  atlen = strlen (attr);
+  if (atlen < (int) sizeof (tinybuf) - 1)
+    {
+      memset (tinybuf, 0, sizeof (tinybuf));
+      attrdup = strcpy (tinybuf, attr);
+    }
+  else
+    attrdup = strcpy (xcalloc (atlen + 1, 1), attr);
+  if (!map_mapstringv->entab)
+    {
+      len = basilys_primtab[1];	/* i.e. 3 */
+      if (basilys_is_young (mapstringv))
+	map_mapstringv->entab =
+	  basilysgc_allocate (len *
+			      sizeof (struct entrystringsbasilys_st), 0);
+      else
+	map_mapstringv->entab =
+	  ggc_alloc_cleared (len * sizeof (struct entrystringsbasilys_st));
+      map_mapstringv->lenix = 1;
+      basilysgc_touch (map_mapstringv);
+    }
+  else
+    if ((len = basilys_primtab[map_mapstringv->lenix]) <=
+	(5 * (cnt = map_mapstringv->count)) / 4 + 1
+	|| (len <= 5 && cnt + 1 >= len))
+    {
+      int ix, newcnt = 0;
+      int newlen = basilys_primtab[map_mapstringv->lenix + 1];
+      struct entrystringsbasilys_st *oldtab = NULL;
+      struct entrystringsbasilys_st *newtab = NULL;
+      if (basilys_is_young (mapstringv))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entrystringsbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entrystringsbasilys_st));
+      oldtab = map_mapstringv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  char *curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mapstring (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in old ggc space */
+	ggc_free (oldtab);
+      map_mapstringv->entab = newtab;
+      map_mapstringv->count = newcnt;
+      map_mapstringv->lenix++;
+      basilysgc_touch (map_mapstringv);
+      len = newlen;
+    }
+  ix = unsafe_index_mapstring (map_mapstringv->entab, attrdup, len);
+  gcc_assert (ix >= 0);
+  if (!map_mapstringv->entab[ix].e_at
+      || map_mapstringv->entab[ix].e_at == HTAB_DELETED_ENTRY)
+    {
+      char *newat = basilysgc_allocate (atlen + 1, 0);
+      strcpy (newat, attrdup);
+      map_mapstringv->entab[ix].e_at = newat;
+      map_mapstringv->count++;
+    }
+  map_mapstringv->entab[ix].e_va = valuv;
+  basilysgc_touch_dest (map_mapstringv, valuv);
+end:
+  if (attrdup && attrdup != tinybuf)
+    free (attrdup);
+  BASILYS_EXITFRAME ();
+#undef discrv
+#undef mapstringv
+#undef attrobjectv
+#undef valuv
+#undef object_discrv
+#undef object_attrobjectv
+#undef map_mapstringv
+}
+
+basilys_ptr_t
+basilys_get_mapstrings (struct basilysmapstrings_st
+			*mapstring_p, const char *attr)
+{
+  long ix = 0, len = 0;
+  char *oldat = NULL;
+  if (!mapstring_p || !attr)
+    return NULL;
+  if (mapstring_p->discr->object_magic != OBMAG_MAPSTRINGS)
+    return NULL;
+  if (!mapstring_p->entab)
+    return NULL;
+  len = basilys_primtab[mapstring_p->lenix];
+  if (len <= 0)
+    return NULL;
+  ix = unsafe_index_mapstring (mapstring_p->entab, attr, len);
+  if (ix < 0 || !(oldat = mapstring_p->entab[ix].e_at)
+      || oldat == HTAB_DELETED_ENTRY)
+    return NULL;
+  return mapstring_p->entab[ix].e_va;
+}
+
+basilys_ptr_t
+basilysgc_remove_mapstrings (struct basilysmapstrings_st *
+			     mapstring_p, const char *attr)
+{
+  long ix = 0, len = 0, cnt = 0, atlen = 0;
+  const char *oldat = NULL;
+  char *attrdup = 0;
+  char tinybuf[130];
+  BASILYS_ENTERFRAME (3, NULL);
+#define discrv curfram__.varptr[0]
+#define mapstringv curfram__.varptr[1]
+#define valuv curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define map_mapstringv ((struct basilysmapstrings_st*)(mapstringv))
+  mapstringv = mapstring_p;
+  valuv = NULL;
+  if (!mapstringv || !attr || !valuv || !attr[0])
+    goto end;
+  atlen = strlen (attr);
+  discrv = map_mapstringv->discr;
+  if (!discrv || object_discrv->object_magic != OBMAG_MAPSTRINGS)
+    goto end;
+  if (!map_mapstringv->entab)
+    goto end;
+  len = basilys_primtab[map_mapstringv->lenix];
+  if (len <= 0)
+    goto end;
+  if (atlen < (int) sizeof (tinybuf) - 1)
+    {
+      memset (tinybuf, 0, sizeof (tinybuf));
+      attrdup = strcpy (tinybuf, attr);
+    }
+  else
+    attrdup = strcpy (xcalloc (atlen + 1, 1), attr);
+  ix = unsafe_index_mapstring (map_mapstringv->entab, attrdup, len);
+  if (ix < 0 || !(oldat = map_mapstringv->entab[ix].e_at)
+      || oldat == HTAB_DELETED_ENTRY)
+    goto end;
+  if (!basilys_is_young ((void *) (char *) oldat))
+    ggc_free ((void *) oldat);
+  map_mapstringv->entab[ix].e_at = (void *) HTAB_DELETED_ENTRY;
+  valuv = map_mapstringv->entab[ix].e_va;
+  map_mapstringv->entab[ix].e_va = NULL;
+  map_mapstringv->count--;
+  cnt = map_mapstringv->count;
+  if (len > 7 && 2 * cnt + 2 < len)
+    {
+      int newcnt = 0, newlen = 0, newlenix;
+      struct entrystringsbasilys_st *oldtab = NULL, *newtab = NULL;
+      for (newlenix = map_mapstringv->lenix;
+	   (newlen = basilys_primtab[newlenix]) > 2 * cnt + 3; newlenix--);
+      if (newlen >= len)
+	goto end;
+      if (basilys_is_young (mapstringv))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entrystringsbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entrystringsbasilys_st));
+      oldtab = map_mapstringv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  char *curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mapstring (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in ol<d ggc space */
+	ggc_free (oldtab);
+      map_mapstringv->entab = newtab;
+      map_mapstringv->count = newcnt;
+    }
+  basilysgc_touch (map_mapstringv);
+end:
+  if (attrdup && attrdup != tinybuf)
+    free (attrdup);
+  BASILYS_EXITFRAME ();
+  return valuv;
+#undef discrv
+#undef mapstringv
+#undef valuv
+#undef object_discrv
+#undef map_mapstringv
+}
+
+
+
+/* index of entry to get or add an attribute in an mappointer (or -1 on error) */
+struct entrypointerbasilys_st
+{
+  const void *e_at;
+  basilys_ptr_t e_va;
+};
+static inline int
+unsafe_index_mappointer (struct entrypointerbasilys_st *tab,
+			 const void *attr, int siz)
+{
+  int ix = 0, frix = -1;
+  unsigned h = 0;
+  if (!tab || !attr || siz <= 0)
+    return -1;
+  h = ((unsigned) (((long) (attr)) >> 3)) & BASILYS_MAXHASH;
+  h = h % siz;
+  for (ix = h; ix < siz; ix++)
+    {
+      const void *curat = tab[ix].e_at;
+      if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+      else if (curat == attr)
+	return ix;
+    }
+  for (ix = 0; ix < (int) h; ix++)
+    {
+      const void *curat = tab[ix].e_at;
+      if (curat == (void *) HTAB_DELETED_ENTRY)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	}
+      else if (!curat)
+	{
+	  if (frix < 0)
+	    frix = ix;
+	  return frix;
+	}
+      else if (curat == attr)
+	return ix;
+    }
+  return -1;			/* entirely full, should not happen */
+}
+
+
+/* this should be the same as basilysmaptrees_st, basilysmapedges_st,
+   basilysmapbasicblocks_st, .... */
+struct basilysmappointers_st
+{
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entrypointerbasilys_st *entab;
+  /* the following field is usually the value of entab (for
+     objects in the young zone), to allocate the object and its fields
+     at once */
+  struct entrypointerbasilys_st map_space[FLEXIBLE_DIM];
+};
+/* allocate a new empty mappointers without checks */
+void *
+basilysgc_raw_new_mappointers (basilysobject_ptr_t discr_p, unsigned len)
+{
+  int lenix = 0, primlen = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv curfram__.varptr[0]
+#define newmapv curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define map_newmapv ((struct basilysmappointers_st*)(newmapv))
+  discrv = discr_p;
+  if (len > 0)
+    {
+      gcc_assert (len < (unsigned) BASILYS_MAXLEN);
+      for (lenix = 1;
+	   (primlen = (int) basilys_primtab[lenix]) != 0
+	   && primlen <= (int) len; lenix++);
+    };
+  gcc_assert (sizeof (struct entrypointerbasilys_st) ==
+	      sizeof (struct entrytreesbasilys_st));
+  gcc_assert (sizeof (struct entrypointerbasilys_st) ==
+	      sizeof (struct entryedgesbasilys_st));
+  gcc_assert (sizeof (struct entrypointerbasilys_st) ==
+	      sizeof (struct entrybasicblocksbasilys_st));
+  newmapv =
+    basilysgc_allocate (offsetof
+			(struct basilysmappointers_st,
+			 map_space),
+			primlen * sizeof (struct entrypointerbasilys_st));
+  map_newmapv->discr = object_discrv;
+  map_newmapv->count = 0;
+  map_newmapv->lenix = lenix;
+  if (len > 0)
+    map_newmapv->entab = map_newmapv->map_space;
+  else
+    map_newmapv->entab = NULL;
+  BASILYS_EXITFRAME ();
+  return newmapv;
+#undef discrv
+#undef newmapv
+#undef object_discrv
+#undef map_newmapv
+}
+
+
+void
+basilysgc_raw_put_mappointers (void *mappointer_p,
+			       const void *attr, basilys_ptr_t valu_p)
+{
+  long ix = 0, len = 0, cnt = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define mappointerv curfram__.varptr[0]
+#define valuv curfram__.varptr[1]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define map_mappointerv ((struct basilysmappointers_st*)(mappointerv))
+  mappointerv = mappointer_p;
+  valuv = valu_p;
+  if (!map_mappointerv->entab)
+    {
+      len = basilys_primtab[1];	/* i.e. 3 */
+      if (basilys_is_young (mappointerv))
+	map_mappointerv->entab =
+	  basilysgc_allocate (len *
+			      sizeof (struct entrypointerbasilys_st), 0);
+      else
+	map_mappointerv->entab =
+	  ggc_alloc_cleared (len * sizeof (struct entrypointerbasilys_st));
+      map_mappointerv->lenix = 1;
+      basilysgc_touch (map_mappointerv);
+    }
+  else
+    if ((len = basilys_primtab[map_mappointerv->lenix]) <=
+	(5 * (cnt = map_mappointerv->count)) / 4 + 1
+	|| (len <= 5 && cnt + 1 >= len))
+    {
+      int ix, newcnt = 0;
+      int newlen = basilys_primtab[map_mappointerv->lenix + 1];
+      struct entrypointerbasilys_st *oldtab = NULL;
+      struct entrypointerbasilys_st *newtab = NULL;
+      if (basilys_is_young (mappointerv))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entrypointerbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entrypointerbasilys_st));
+      oldtab = map_mappointerv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  const void *curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mappointer (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in old ggc space */
+	ggc_free (oldtab);
+      map_mappointerv->entab = newtab;
+      map_mappointerv->count = newcnt;
+      map_mappointerv->lenix++;
+      basilysgc_touch (map_mappointerv);
+      len = newlen;
+    }
+  ix = unsafe_index_mappointer (map_mappointerv->entab, attr, len);
+  gcc_assert (ix >= 0);
+  if (!map_mappointerv->entab[ix].e_at
+      || map_mappointerv->entab[ix].e_at == HTAB_DELETED_ENTRY)
+    {
+      map_mappointerv->entab[ix].e_at = attr;
+      map_mappointerv->count++;
+    }
+  map_mappointerv->entab[ix].e_va = valuv;
+  basilysgc_touch_dest (map_mappointerv, valuv);
+  BASILYS_EXITFRAME ();
+#undef discrv
+#undef mappointerv
+#undef valuv
+#undef object_discrv
+#undef map_mappointerv
+}
+
+basilys_ptr_t
+basilys_raw_get_mappointers (void *map, const void *attr)
+{
+  long ix = 0, len = 0;
+  const void *oldat = NULL;
+  struct basilysmappointers_st *mappointer_p = map;
+  if (!mappointer_p->entab)
+    return NULL;
+  len = basilys_primtab[mappointer_p->lenix];
+  if (len <= 0)
+    return NULL;
+  ix = unsafe_index_mappointer (mappointer_p->entab, attr, len);
+  if (ix < 0 || !(oldat = mappointer_p->entab[ix].e_at)
+      || oldat == HTAB_DELETED_ENTRY)
+    return NULL;
+  return mappointer_p->entab[ix].e_va;
+}
+
+basilys_ptr_t
+basilysgc_raw_remove_mappointers (void *mappointer_p, const void *attr)
+{
+  long ix = 0, len = 0, cnt = 0;
+  const char *oldat = NULL;
+  BASILYS_ENTERFRAME (3, NULL);
+#define discrv curfram__.varptr[0]
+#define mappointerv curfram__.varptr[1]
+#define valuv curfram__.varptr[2]
+#define object_discrv ((basilysobject_ptr_t)(discrv))
+#define map_mappointerv ((struct basilysmappointers_st*)(mappointerv))
+  mappointerv = mappointer_p;
+  valuv = NULL;
+  if (!map_mappointerv->entab)
+    goto end;
+  len = basilys_primtab[map_mappointerv->lenix];
+  if (len <= 0)
+    goto end;
+  ix = unsafe_index_mappointer (map_mappointerv->entab, attr, len);
+  if (ix < 0 || !(oldat = map_mappointerv->entab[ix].e_at)
+      || oldat == HTAB_DELETED_ENTRY)
+    goto end;
+  map_mappointerv->entab[ix].e_at = (void *) HTAB_DELETED_ENTRY;
+  valuv = map_mappointerv->entab[ix].e_va;
+  map_mappointerv->entab[ix].e_va = NULL;
+  map_mappointerv->count--;
+  cnt = map_mappointerv->count;
+  if (len > 7 && 2 * cnt + 2 < len)
+    {
+      int newcnt = 0, newlen = 0, newlenix;
+      struct entrypointerbasilys_st *oldtab = NULL, *newtab = NULL;
+      for (newlenix = map_mappointerv->lenix;
+	   (newlen = basilys_primtab[newlenix]) > 2 * cnt + 3; newlenix--);
+      if (newlen >= len)
+	goto end;
+      if (basilys_is_young (mappointerv))
+	newtab =
+	  basilysgc_allocate (newlen *
+			      sizeof (struct entrypointerbasilys_st), 0);
+      else
+	newtab =
+	  ggc_alloc_cleared (newlen * sizeof (struct entrypointerbasilys_st));
+      oldtab = map_mappointerv->entab;
+      for (ix = 0; ix < len; ix++)
+	{
+	  const void *curat = oldtab[ix].e_at;
+	  int newix;
+	  if (!curat || curat == (void *) HTAB_DELETED_ENTRY)
+	    continue;
+	  newix = unsafe_index_mappointer (newtab, curat, newlen);
+	  gcc_assert (newix >= 0);
+	  newtab[newix] = oldtab[ix];
+	  newcnt++;
+	}
+      if (!basilys_is_young (oldtab))
+	/* free oldtab since it is in old ggc space */
+	ggc_free (oldtab);
+      map_mappointerv->entab = newtab;
+      map_mappointerv->count = newcnt;
+    }
+  basilysgc_touch (map_mappointerv);
+end:
+  BASILYS_EXITFRAME ();
+  return valuv;
+#undef discrv
+#undef mappointerv
+#undef valuv
+#undef object_discrv
+#undef map_mappointerv
+}
+
+
+/***************** objvlisp test of strict subclassing */
+bool
+basilys_is_subclass_of (basilysobject_ptr_t subclass_p,
+			basilysobject_ptr_t superclass_p)
+{
+  struct basilysmultiple_st *subanc = NULL;
+  struct basilysmultiple_st *superanc = NULL;
+  unsigned subdepth = 0, superdepth = 0;
+  if (basilys_magic_discr ((basilys_ptr_t) subclass_p) !=
+      OBMAG_OBJECT || subclass_p->object_magic != OBMAG_OBJECT
+      || basilys_magic_discr ((basilys_ptr_t) superclass_p) !=
+      OBMAG_OBJECT || superclass_p->object_magic != OBMAG_OBJECT)
+    {
+      gcc_unreachable ();
+      return FALSE;
+    }
+  if (subclass_p->obj_len < FCLASS__LAST
+      || !subclass_p->obj_vartab
+      || superclass_p->obj_len < FCLASS__LAST || !superclass_p->obj_vartab)
+    {
+      gcc_unreachable ();
+      return FALSE;
+    }
+  if (superclass_p == BASILYSGOB (CLASS_ROOT))
+    return TRUE;
+  subanc =
+    (struct basilysmultiple_st *) subclass_p->obj_vartab[FCLASS_ANCESTORS];
+  superanc =
+    (struct basilysmultiple_st *) superclass_p->obj_vartab[FCLASS_ANCESTORS];
+  if (basilys_magic_discr ((basilys_ptr_t) subanc) !=
+      OBMAG_MULTIPLE || subanc->discr != BASILYSGOB (DISCR_SEQCLASS))
+    {
+      gcc_unreachable ();
+      return FALSE;
+    }
+  if (basilys_magic_discr ((basilys_ptr_t) superanc) !=
+      OBMAG_MULTIPLE || superanc->discr != BASILYSGOB (DISCR_SEQCLASS))
+    {
+      gcc_unreachable ();
+      return FALSE;
+    }
+  subdepth = subanc->nbval;
+  superdepth = superanc->nbval;
+  if (subdepth <= superdepth)
+    return FALSE;
+  if ((basilys_ptr_t) subanc->tabval[superdepth] ==
+      (basilys_ptr_t) superclass_p)
+    return TRUE;
+  return FALSE;
+}
+
+
+basilys_ptr_t
+basilysgc_new_string (basilysobject_ptr_t discr_p, const char *str)
+{
+  int slen = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv     curfram__.varptr[0]
+#define strv       curfram__.varptr[1]
+#define obj_discrv  ((struct basilysobject_st*)(discrv))
+#define str_strv  ((struct basilysstring_st*)(strv))
+  strv = 0;
+  if (!str)
+    goto end;
+  slen = strlen (str);
+  discrv = discr_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (obj_discrv->object_magic != OBMAG_STRING)
+    goto end;
+  strv = basilysgc_allocate (sizeof (struct basilysstring_st), slen + 1);
+  str_strv->discr = obj_discrv;
+  strcpy (str_strv->val, str);
+end:
+  BASILYS_EXITFRAME ();
+  return strv;
+#undef discrv
+#undef strv
+#undef obj_discrv
+#undef str_strv
+}
+
+basilys_ptr_t
+basilysgc_new_stringdup (basilysobject_ptr_t discr_p, const char *str)
+{
+  int slen = 0;
+  char tinybuf[80];
+  char *strcop = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv     curfram__.varptr[0]
+#define strv       curfram__.varptr[1]
+#define obj_discrv  ((struct basilysobject_st*)(discrv))
+#define str_strv  ((struct basilysstring_st*)(strv))
+  strv = 0;
+  if (!str)
+    goto end;
+  discrv = discr_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (obj_discrv->object_magic != OBMAG_STRING)
+    goto end;
+  slen = strlen (str);
+  if (slen < (int) sizeof (tinybuf) - 1)
+    {
+      memset (tinybuf, 0, sizeof (tinybuf));
+      strcop = strcpy (tinybuf, str);
+    }
+  else
+    strcop = strcpy (xcalloc (1, slen + 1), str);
+  strv = basilysgc_allocate (sizeof (struct basilysstring_st), slen + 1);
+  str_strv->discr = obj_discrv;
+  strcpy (str_strv->val, strcop);
+end:
+  if (strcop && strcop != tinybuf)
+    free (strcop);
+  memset (tinybuf, 0, sizeof (tinybuf));
+  BASILYS_EXITFRAME ();
+  return strv;
+#undef discrv
+#undef strv
+#undef obj_discrv
+#undef str_strv
+}
+
+basilys_ptr_t
+basilysgc_new_string_nakedbasename (basilysobject_ptr_t
+				    discr_p, const char *str)
+{
+  int slen = 0;
+  char tinybuf[120];
+  char *strcop = 0;
+  char *basestr = 0;
+  char *dot = 0;
+  BASILYS_ENTERFRAME (2, NULL);
+#define discrv     curfram__.varptr[0]
+#define strv       curfram__.varptr[1]
+#define obj_discrv  ((struct basilysobject_st*)(discrv))
+#define str_strv  ((struct basilysstring_st*)(strv))
+  strv = 0;
+  if (!str)
+    goto end;
+  discrv = discr_p;
+  if (basilys_magic_discr (discrv) != OBMAG_OBJECT)
+    goto end;
+  if (obj_discrv->object_magic != OBMAG_STRING)
+    goto end;
+  slen = strlen (str);
+  if (slen < (int) sizeof (tinybuf) - 1)
+    {
+      memset (tinybuf, 0, sizeof (tinybuf));
+      strcop = strcpy (tinybuf, str);
+    }
+  else
+    strcop = strcpy (xcalloc (1, slen + 1), str);
+  basestr = (char *) lbasename (strcop);
+  dot = strchr (basestr, '.');
+  if (dot)
+    *dot = 0;
+  strv =
+    basilysgc_allocate (sizeof (struct basilysstring_st),
+			strlen (basestr) + 1);
+  str_strv->discr = obj_discrv;
+  strcpy (str_strv->val, basestr);
+end:
+  if (strcop && strcop != tinybuf)
+    free (strcop);
+  memset (tinybuf, 0, sizeof (tinybuf));
+  BASILYS_EXITFRAME ();
+  return strv;
+#undef discrv
+#undef strv
+#undef obj_discrv
+#undef str_strv
+}
+
+
+#if 0 && NOT_NEEDED
+static const char *
+copynamestring (const char *string)
+{
+  size_t len = strlen (string) + 1;
+  char *s = (char *) obstack_alloc (&bname_obstack, len);
+  strcpy (s, string);
+  return s;
+}
+#endif
+
+
+#if ENABLE_CHECKING
+static long applcount_basilys;
+static int appldepth_basilys;
+#define MAXDEPTH_APPLY_BASILYS 2000
+#endif
+/*************** closure application ********************/
+basilys_ptr_t
+basilysgc_apply (basilysclosure_ptr_t clos_p,
+		 basilys_ptr_t arg1_p,
+		 const char *xargdescr_,
+		 union basilysparam_un *xargtab_,
+		 const char *xresdescr_, union basilysparam_un *xrestab_)
+{
+  basilys_ptr_t res = NULL;
+  union
+  {
+    long funad[1 + sizeof (basilysroutfun_t *) / sizeof (long)];
+    basilysroutfun_t *pfun;
+  }
+  ufun;
+#if ENABLE_CHECKING
+  applcount_basilys++;
+  appldepth_basilys++;
+  if (appldepth_basilys > MAXDEPTH_APPLY_BASILYS)
+    fatal_error ("too deep (%d) basilys application", appldepth_basilys);
+#endif
+  memset (&ufun, 0, sizeof (ufun));
+  if (basilys_magic_discr ((void *) clos_p) != OBMAG_CLOSURE)
+    return NULL;
+  if (basilys_magic_discr ((void *) clos_p->rout) !=
+      OBMAG_ROUTINE || !clos_p->rout->routaddr)
+    return NULL;
+  memcpy (&ufun.funad, clos_p->rout->routaddr,
+	  sizeof (clos_p->rout->routaddr));
+  gcc_assert (ufun.pfun);
+  /* only make sense on AMD64/Linux */
+  gcc_assert (((unsigned long) ufun.pfun) > 4096UL
+	      && ((unsigned long) ufun.pfun) < 0xffffffffff600000UL);
+  res =
+    (*ufun.pfun) (clos_p, arg1_p, xargdescr_, xargtab_, xresdescr_, xrestab_);
+#if ENABLE_CHECKING
+  appldepth_basilys--;
+#endif
+  return res;
+}
+
+
+
+/************** method sending ***************/
+basilys_ptr_t
+basilysgc_send (basilys_ptr_t recv_p,
+		basilys_ptr_t sel_p,
+		const char *xargdescr_,
+		union basilysparam_un * xargtab_,
+		const char *xresdescr_, union basilysparam_un * xrestab_)
+{
+#ifdef ENABLE_CHECKING
+  static long sendcount;
+  long sendnum = ++sendcount;
+#endif
+  BASILYS_ENTERFRAME (9, NULL);
+#define recv    curfram__.varptr[0]
+#define selv    curfram__.varptr[1]
+#define argv    curfram__.varptr[2]
+#define closv   curfram__.varptr[3]
+#define discrv  curfram__.varptr[4]
+#define mapv    curfram__.varptr[5]
+#define superv  curfram__.varptr[6]
+#define resv    curfram__.varptr[7]
+#define ancv    curfram__.varptr[8]
+#define obj_discrv ((basilysobject_ptr_t)(discrv))
+#define obj_selv ((basilysobject_ptr_t)(selv))
+#define clo_closv ((basilysclosure_ptr_t)(closv))
+#define mul_ancv  ((struct basilysmultiple_st*)(ancv))
+  recv = recv_p;
+  selv = sel_p;
+  if (!recv)
+    goto end;
+#ifdef ENABLE_CHECKING
+  (void) sendnum;		/* to use it */
+#endif
+  if (basilys_magic_discr (selv) != OBMAG_OBJECT)
+    goto end;
+  if (!basilys_is_instance_of (selv, BASILYSG (CLASS_SELECTOR)))
+    goto end;
+#if 0 && ENABLE_CHECKING
+  debugeprintf ("send #%ld recv %p", sendnum, (void *) recv);
+  debugeprintf ("send #%ld selv %p <%s>", sendnum,
+		(void *) obj_selv,
+		basilys_string_str (obj_selv->obj_vartab[FNAMED_NAME]));
+#endif
+  discrv =
+    recv ? ((basilys_ptr_t) recv)->u_discr : BASILYSGOB (DISCR_NULLRECV);
+  while (discrv)
+    {
+      gcc_assert (basilys_magic_discr (discrv) == OBMAG_OBJECT);
+      gcc_assert (obj_discrv->obj_len >= FDISCR__LAST);
+#if 0 && ENABLE_CHECKING
+      debugeprintf ("send #%ld discrv %p <%s>",
+		    sendnum, discrv,
+		    basilys_string_str (obj_discrv->obj_vartab[FNAMED_NAME]));
+#endif
+      mapv = obj_discrv->obj_vartab[FDISCR_METHODICT];
+      if (basilys_magic_discr (mapv) == OBMAG_MAPOBJECTS)
+	{
+	  closv = basilys_get_mapobjects (mapv, selv);
+	}
+      else
+	{
+	  closv = obj_discrv->obj_vartab[FDISCR_SENDCLOSURE];
+	  if (basilys_magic_discr (closv) == OBMAG_CLOSURE)
+	    {
+	      union basilysparam_un pararg[1];
+	      pararg[0].bp_aptr = (basilys_ptr_t *) & selv;
+	      resv = basilysgc_apply (closv, recv, BPARSTR_PTR, pararg,
+				      "", NULL);
+	      closv = resv;
+	    }
+	}
+      if (basilys_magic_discr (closv) == OBMAG_CLOSURE)
+	{
+#if 0 && ENABLE_CHECKING
+	  debugeprintf ("send #%ld applying closv %p", sendnum, closv);
+#endif
+	  resv =
+	    basilysgc_apply (closv, recv, xargdescr_, xargtab_,
+			     xresdescr_, xrestab_);
+	  goto end;
+	}
+      discrv = obj_discrv->obj_vartab[FDISCR_SUPER];
+    }				/* end while discrv */
+  resv = NULL;
+end:
+#if 0 && ENABLE_CHECKING
+  debugeprintf ("endsend #%ld recv %p resv %p selv %p <%s>",
+		sendnum, recv, resv, (void *) obj_selv,
+		basilys_string_str (obj_selv->obj_vartab[FNAMED_NAME]));
+#endif
+  BASILYS_EXITFRAME ();
+  return resv;
+#undef recv
+#undef selv
+#undef closv
+#undef discrv
+#undef argv
+#undef mapv
+#undef superv
+#undef resv
+#undef ancv
+#undef obj_discrv
+#undef obj_selv
+#undef clo_closv
+}
+
+
+/* the srcfile is a generated .c file, the dlfile has no suffix,
+   because the suffix is expected to be added by the basilys-gcc
+   script */
+static void
+compile_to_dyl (const char *srcfile, const char *dlfile)
+{
+  struct pex_obj *pex = 0;
+  int err = 0;
+  int cstatus = 0;
+  const char *errmsg = 0;
+  /* possible improvement for GlobalGcc partners : avoid recompiling
+     when not necessary; using timestamps a la make is not enough,
+     since the C source files are generated.  
+
+The basilys-gcc script takes two arguments: the C source file path to
+compile as a basilys plugin, and the naked dynamic library file to be
+generated. A standard path for this script should be defined, and the
+default should neither be getenv-ed not be built-in (as the
+"basilys-gcc" string below) but somehow parametrized.
+
+The basilys-gcc script should be generated in the building process.
+In addition of compiling the C source file, it should put into the
+generated dynamic library the following two constant strings;
+  const char basilys_compiled_timestamp[];
+  const char basilys_md5[];
+
+the basilys_compiled_timestamp should contain a human readable
+timestamp the basilys_md5 should contain the hexadecimal md5 digest,
+followed by the source file name (i.e. the single line output by the
+command: md5sum $Csourcefile; where $Csourcefile is replaced by the
+source file path)
+
+   */
+  const char *basilysgcccmd = getenv ("BASILYS_GCC");
+  struct pex_time ptime;
+  char *argv[4];
+  memset (&ptime, 0, sizeof (ptime));
+  if (!basilysgcccmd)
+    basilysgcccmd = "basilys-gcc";
+  debugeprintf ("compile_to_dyl srcfile %s dlfile %s", srcfile, dlfile);
+  fflush (stdout);
+  fflush (stderr);
+  pex = pex_init (PEX_RECORD_TIMES, basilysgcccmd, NULL);
+  argv[0] = (char *) basilysgcccmd;
+  argv[1] = (char *) srcfile;
+  argv[2] = (char *) dlfile;
+  argv[3] = (char *) 0;
+  errmsg =
+    pex_run (pex, PEX_LAST | PEX_SEARCH, basilysgcccmd, argv,
+	     NULL, NULL, &err);
+  if (errmsg)
+    fatal_error
+      ("failed to basilys compile to dyl: %s %s %s : %s",
+       basilysgcccmd, srcfile, dlfile, errmsg);
+  if (!pex_get_status (pex, 1, &cstatus))
+    fatal_error
+      ("failed to get status of basilys dynamic compilation to dyl:  %s %s %s - %m",
+       basilysgcccmd, srcfile, dlfile);
+  if (!pex_get_times (pex, 1, &ptime))
+    fatal_error
+      ("failed to get time of basilys dynamic compilation to dyl:  %s %s %s - %m",
+       basilysgcccmd, srcfile, dlfile);
+  pex_free (pex);
+  debugeprintf ("compile_to_dyl done srcfile %s dlfile %s", srcfile, dlfile);
+}
+
+
+
+
+/* compile (as a dynamically loadable module) some (usually generated)
+   C code and dynamically load it; the C code should contain a
+   function named start_module_basilys; that function is called with
+   the given modata and returns the module */
+basilys_ptr_t
+basilysgc_compile_dyn (basilys_ptr_t modata_p, const char *srcfile)
+{
+  char *srcpath = 0, *shobjpath = 0;
+  lt_dlhandle dlh = 0;
+  lt_ptr dlsy = 0;
+  typedef basilys_ptr_t startroutine_t (basilys_ptr_t);
+  startroutine_t *starout = 0;
+  BASILYS_ENTERFRAME (3, NULL);
+#define modulv curfram__.varptr[0]
+#define mdatav curfram__.varptr[1]
+  mdatav = modata_p;
+  srcpath = xstrdup (srcfile);
+  shobjpath = 0;
+  debugeprintf ("basilysgc_compile srcfile=%s", srcfile);
+  if (access (srcpath, R_OK))
+    fatal_error ("no source file %s to basilys compile : %m", srcpath);
+  /* @@@ this is too simplistic; the tldl library is able to deal with
+     shared objects which are not named .so but something else; some
+     GlobalGcc partner is expected to improve this, to take the
+     following into account: 
+
+     * looking in some well defined directory containing the basilys
+     dynamic libraries. This directory should be supported by the
+     build process
+
+     * if a dynamic library of suitable name is found, check that its
+     basilys_md5 is the same as the md5 signature of the source file,
+     and change the shobjpath variable accordingly
+
+     * if a dynamic library is not found, make a suitable temporary
+     file (whose suffix is not always .so, but could be .dylib on
+     MacOSX, etc...
+
+  **/
+  shobjpath = make_temp_file (".so");
+  debugeprintf ("basilysgc_compile srcpath=%s shobjpath=%s",
+		srcpath, shobjpath);
+  compile_to_dyl (srcpath, shobjpath);
+  /** end of code to be improved by some GlobalGcc partner; everything
+      below is ok @@@ */
+  dlh = lt_dlopenext (shobjpath);
+  if (!dlh)
+    fatal_error
+      ("basilysgc_compile failed to lt_dlopenext src=%s shobj=%s - %s",
+       srcpath, shobjpath, lt_dlerror ());
+  dlsy = lt_dlsym (dlh, "start_module_basilys");
+  if (!dlsy)
+    fatal_error
+      ("basilysgc_compile failed to lt_dlsym start_module_basilys in src=%s shobj=%ss - %s",
+       srcpath, shobjpath, lt_dlerror ());
+  starout = (startroutine_t *) dlsy;
+  debugeprintvalue ("mdatav before calling start_module_basilys", mdatav);
+  debugeprintf
+    ("basilysgc_compile before calling start_module_basilys @%p",
+     (void *) dlsy);
+  modulv = (*starout) (mdatav);
+  debugeprintvalue ("modulv after calling start_module_basilys", modulv);
+  BASILYS_EXITFRAME ();
+  return modulv;
+#undef mdatav
+#undef modulv
+}
+
+/*************** initial load machinery *******************/
+
+
+struct reading_st
+{
+  FILE *rfil;
+  const char *rpath;
+  char *rcurlin;		/* current line mallocated buffer */
+  int rlineno;			/* current line number */
+  int rcol;			/* current column */
+  basilys_ptr_t *rpfilnam;	/* pointer to location of file name string */
+  basilys_ptr_t *rpgenv;	/* pointer to location of environment */
+};
+/* Obstack used for reading strings */
+static struct obstack bstring_obstack;
+#define rdback() (rd->rcol--)
+#define rdnext() (rd->rcol++)
+#define rdcurc() rd->rcurlin[rd->rcol]
+#define rdfollowc(Rk) rd->rcurlin[rd->rcol + (Rk)]
+#define rdeof() (feof(rd->rfil) && rd->rcurlin[rd->rcol]==0)
+#define READ_ERROR(Fmt,...)					\
+  fatal_error("%s:%d:%d: read error <%s:%d> - " Fmt,		\
+	      rd->rpath, rd->rlineno,	rd->rcol,		\
+	      basename(__FILE__),__LINE__, ##__VA_ARGS__)
+/* readval returns the read value and sets *PGOT to true if something
+   was read */
+static basilys_ptr_t readval (struct reading_st *rd, bool * pgot);
+static int
+skipspace_getc (struct reading_st *rd)
+{
+  int c = 0;
+  int incomm = 0;
+readagain:
+  if (rdeof ())
+    return EOF;
+  if (!rd->rcurlin)
+    goto readline;
+  c = rdcurc ();
+  if (c == '\n' || c == 0)
+  readline:
+    {
+      /* we expect most lines to fit into linbuf, so we don't handle
+         efficiently long lines */
+      static char linbuf[400];
+      char *mlin = 0;		/* partial mallocated line buffer when
+				   not fitting into linbuf */
+      char *eol = 0;
+      if (rd->rcurlin)
+	free ((void *) rd->rcurlin);
+      rd->rcurlin = NULL;
+      /* we really want getline here .... */
+      for (;;)
+	{
+	  memset (linbuf, 0, sizeof (linbuf));
+	  eol = NULL;
+	  if (!fgets (linbuf, sizeof (linbuf), rd->rfil))
+	    {
+	      /* reached eof, so either give mlin or duplicate an empty
+	         line */
+	      if (mlin)
+		rd->rcurlin = mlin;
+	      else
+		rd->rcurlin = xstrdup ("");
+	      break;
+	    }
+	  else
+	    eol = strchr (linbuf, '\n');
+	  if (eol)
+	    {
+	      if (rd->rcurlin)
+		free ((void *) rd->rcurlin);
+	      if (!mlin)
+		rd->rcurlin = xstrdup (linbuf);
+	      else
+		{
+		  rd->rcurlin = concat (mlin, linbuf, NULL);
+		  free (mlin);
+		}
+	      break;
+	    }
+	  else
+	    {
+	      /* read partly a long line without reaching the end of line */
+	      if (mlin)
+		{
+		  char *newmlin = concat (mlin, linbuf, NULL);
+		  free (mlin);
+		  mlin = newmlin;
+		}
+	      else
+		mlin = xstrdup (linbuf);
+	    }
+	};
+      rd->rlineno++;
+      rd->rcol = 0;
+      goto readagain;
+    }
+  else if (c == ';')
+    goto readline;
+  else if (c == '#' && rdfollowc (1) == '|')
+    {
+      incomm = 1;
+      rdnext ();
+      c = rdcurc ();
+      goto readagain;
+    }
+  else if (incomm && c == '|' && rdfollowc (1) == '#')
+    {
+      incomm = 0;
+      rdnext ();
+      rdnext ();
+      c = rdcurc ();
+      goto readagain;
+    }
+  else if (ISSPACE (c) || incomm)
+    {
+      rdnext ();
+      c = rdcurc ();
+      goto readagain;
+    }
+  else
+    return c;
+}
+
+
+#define EXTRANAMECHARS "_+-*/<>=!?:%~&@$"
+/* read a simple name on the bname_obstack */
+static char *
+readsimplename (struct reading_st *rd)
+{
+  int c = 0;
+  while (!rdeof () && (c = rdcurc ()) > 0 &&
+	 (ISALNUM (c) || strchr (EXTRANAMECHARS, c) != NULL))
+    {
+      obstack_1grow (&bname_obstack, (char) c);
+      rdnext ();
+    }
+  obstack_1grow (&bname_obstack, (char) 0);
+  return XOBFINISH (&bname_obstack, char *);
+}
+
+
+/* read an integer, like +123, which may also be +%numbername or +|fieldname */
+static long
+readsimplelong (struct reading_st *rd)
+{
+  int c = 0;
+  long r = 0;
+  char *endp = 0;
+  char *nam = 0;
+  bool neg = FALSE;
+  /* we do not need any GC locals ie BASILYS_ENTERFRAME because no
+     garbage collection occurs here */
+  c = rdcurc ();
+  if (((c == '+' || c == '-') && ISDIGIT (rdfollowc (1))) || ISDIGIT (c))
+    {
+      /* R5RS and R6RS require decimal notation -since the binary and
+         hex numbers are hash-prefixed but for convenience we accept
+         them thru strtol */
+      r = strtol (&rdcurc (), &endp, 0);
+      if (r == 0 && endp <= &rdcurc ())
+	READ_ERROR ("failed to read number %.20s", &rdcurc ());
+      rd->rcol += endp - &rdcurc ();
+      return r;
+    }
+  else if ((c == '+' || c == '-') && rdfollowc (1) == '%')
+    {
+      neg = (c == '-');
+      rdnext ();
+      rdnext ();
+      nam = readsimplename (rd);
+      r = -1;
+      /* the +%magicname notation is seldom used, we don't care to do
+         many needless strcmp-s in that case, to be able to define the
+         below simple macro */
+      if (!nam)
+	READ_ERROR
+	  ("magic number name expected after +%% or -%% for magic %s", nam);
+#define NUMNAM(N) else if (!strcmp(nam,#N)) r = (N)
+      NUMNAM (OBMAG_OBJECT);
+      NUMNAM (OBMAG_MULTIPLE);
+      NUMNAM (OBMAG_BOX);
+      NUMNAM (OBMAG_CLOSURE);
+      NUMNAM (OBMAG_ROUTINE);
+      NUMNAM (OBMAG_LIST);
+      NUMNAM (OBMAG_PAIR);
+      NUMNAM (OBMAG_TRIPLE);
+      NUMNAM (OBMAG_INT);
+      NUMNAM (OBMAG_MIXINT);
+      NUMNAM (OBMAG_REAL);
+      NUMNAM (OBMAG_STRING);
+      NUMNAM (OBMAG_STRBUF);
+      NUMNAM (OBMAG_TREE);
+      NUMNAM (OBMAG_BASICBLOCK);
+      NUMNAM (OBMAG_EDGE);
+      NUMNAM (OBMAG_MAPOBJECTS);
+      NUMNAM (OBMAG_MAPSTRINGS);
+      NUMNAM (OBMAG_MAPTREES);
+      NUMNAM (OBMAG_MAPBASICBLOCKS);
+      NUMNAM (OBMAG_MAPEDGES);
+      NUMNAM (OBMAG_DECAY);
+      NUMNAM (OBMAG_SPEC_FILE);
+      NUMNAM (OBMAG_SPEC_MPFR);
+      NUMNAM (OBMAG_SPECPPL_COEFFICIENT);
+      NUMNAM (OBMAG_SPECPPL_LINEAR_EXPRESSION);
+      NUMNAM (OBMAG_SPECPPL_CONSTRAINT);
+      NUMNAM (OBMAG_SPECPPL_CONSTRAINT_SYSTEM);
+      NUMNAM (OBMAG_SPECPPL_GENERATOR);
+      NUMNAM (OBMAG_SPECPPL_GENERATOR_SYSTEM);
+      NUMNAM (FPROPED_PROP);
+      NUMNAM (FPROPED__LAST);
+      NUMNAM (FNAMED_NAME);
+      NUMNAM (FNAMED__LAST);
+      NUMNAM (FDISCR_METHODICT);
+      NUMNAM (FDISCR_SENDCLOSURE);
+      NUMNAM (FDISCR__LAST);
+      NUMNAM (FCLASS_ANCESTORS);
+      NUMNAM (FCLASS_FIELDS);
+      NUMNAM (FCLASS_OBJNUMDESCR);
+      NUMNAM (FCLASS_DATA);
+      NUMNAM (FCLASS__LAST);
+      NUMNAM (FSEXPR_LOCATION);
+      NUMNAM (FSEXPR_CONTENTS);
+      NUMNAM (FSEXPR__LAST);
+      /***
+      not @NumNam (FFIELD_OWNCLASS);
+      not @NumNam (FFIELD_TYPINFO);
+      not @NumNam (FFIELD__LAST);
+      not @NumNam (FRENV_MACRODICT);
+      not @NumNam (FRENV_NAMEBIND);
+      not @NumNam (FRENV_PARENTENV);
+      not @NumNam (FRENV__LAST);
+      not @NumNam (FSYMB_DATA);
+      not @NumNam (FSYMB__LAST);
+      not @NumNam (FQUARK_SIGN);
+      not @NumNam (FQUARK_DATA);
+      not @NumNam (FQUARK__LAST);
+      not @NumNam (BPAR_PTR);
+      not @NumNam (BPAR_RESTPTR);
+      not @NumNam (BPAR_TREE);
+      not @NumNam (BPAR_LONG);
+      not @NumNam (BPAR_EDGE);
+      not @NumNam (BPAR_BB);
+      ***/
+#undef NUMNAM
+      if (r < 0)
+	READ_ERROR ("bad magic number name %s", nam);
+      obstack_free (&bname_obstack, nam);
+      return neg ? -r : r;
+    }
+  else
+    READ_ERROR ("invalid number %.20s", &rdcurc ());
+  return 0;
+}
+
+
+static basilys_ptr_t
+readseqlist (struct reading_st *rd, int endc)
+{
+  int c = 0;
+  int nbcomp = 0;
+  bool got = FALSE;
+  BASILYS_ENTERFRAME (2, NULL);
+#define seqv curfram__.varptr[0]
+#define compv curfram__.varptr[1]
+  seqv = basilysgc_new_list (BASILYSGOB (DISCR_LIST));
+readagain:
+  compv = NULL;
+  c = skipspace_getc (rd);
+  if (c == endc)
+    {
+      rdnext ();
+      goto end;
+    }
+  got = FALSE;
+  compv = readval (rd, &got);
+  if (!compv && !got)
+    READ_ERROR ("unexpected stuff in seq %.20s", &rdcurc ());
+  basilysgc_append_list (seqv, compv);
+  nbcomp++;
+  goto readagain;
+end:
+  BASILYS_EXITFRAME ();
+  return seqv;
+#undef compv
+#undef seqv
+}
+
+
+
+
+static basilys_ptr_t
+makesexpr (struct reading_st *rd, int lineno, basilys_ptr_t contents_p)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define sexprv  curfram__.varptr[0]
+#define contsv   curfram__.varptr[1]
+#define locmixv curfram__.varptr[2]
+  contsv = contents_p;
+  gcc_assert (basilys_magic_discr (contsv) == OBMAG_LIST);
+  locmixv = basilysgc_new_mixint (BASILYSGOB (DISCR_MIXEDINT),
+				  *rd->rpfilnam, (long) lineno);
+  sexprv = basilysgc_new_raw_object (BASILYSGOB (CLASS_SEXPR), FSEXPR__LAST);
+  ((basilysobject_ptr_t) (sexprv))->obj_vartab[FSEXPR_LOCATION] = locmixv;
+  ((basilysobject_ptr_t) (sexprv))->obj_vartab[FSEXPR_CONTENTS] = contsv;
+  basilysgc_touch (sexprv);
+  BASILYS_EXITFRAME ();
+  return sexprv;
+#undef sexprv
+#undef contsv
+#undef locmixv
+}
+
+
+basilys_ptr_t
+basilysgc_named_symbol (const char *nam, int create)
+{
+  int namlen = 0, ix = 0;
+  char *namdup = 0;
+  char tinybuf[130];
+  BASILYS_ENTERFRAME (4, NULL);
+#define symbv    curfram__.varptr[0]
+#define dictv    curfram__.varptr[1]
+#define closv    curfram__.varptr[2]
+#define nstrv    curfram__.varptr[3]
+  symbv = NULL;
+  dictv = NULL;
+  closv = NULL;
+  if (!nam)
+    goto end;
+  namlen = strlen (nam);
+  memset (tinybuf, 0, sizeof (tinybuf));
+  if (namlen < (int) sizeof (tinybuf) - 2)
+    namdup = strcpy (tinybuf, nam);
+  else
+    namdup = strcpy (xcalloc (namlen + 1, 1), nam);
+  gcc_assert (basilys_magic_discr (BASILYSG (CLASS_TOKENIZER))
+	      == OBMAG_OBJECT);
+  gcc_assert (basilys_magic_discr (BASILYSG (TOKENIZER)) == OBMAG_OBJECT);
+  for (ix = 0; ix < namlen; ix++)
+    if (ISALPHA (namdup[ix]))
+      namdup[ix] = TOUPPER (namdup[ix]);
+  if (basilys_is_instance_of
+      (BASILYSG (TOKENIZER), BASILYSG (CLASS_TOKENIZER))
+      && BASILYSGOB (TOKENIZER)->obj_len >= FTOK__LAST)
+    {
+      dictv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_SYMBDICT];
+      if (basilys_magic_discr (dictv) == OBMAG_MAPSTRINGS)
+	symbv = basilys_get_mapstrings (dictv, namdup);
+      if (symbv || !create)
+	goto end;
+      closv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_ADDSYMB];
+      if (basilys_magic_discr (closv) == OBMAG_CLOSURE)
+	{
+	  union basilysparam_un pararg[1];
+	  memset (&pararg, 0, sizeof (pararg));
+	  nstrv = basilysgc_new_string (BASILYSGOB (DISCR_STRING), namdup);
+	  pararg[0].bp_aptr = (basilys_ptr_t *) & nstrv;
+	  symbv =
+	    basilysgc_apply (closv, BASILYSG (TOKENIZER), BPARSTR_PTR,
+			     pararg, "", NULL);
+	  goto end;
+	}
+    }
+end:;
+  if (namdup && namdup != tinybuf)
+    free (namdup);
+  BASILYS_EXITFRAME ();
+  return symbv;
+#undef symbv
+#undef dictv
+#undef closv
+#undef nstrv
+}
+
+basilys_ptr_t
+basilysgc_intern_symbol (basilys_ptr_t symb_p)
+{
+  BASILYS_ENTERFRAME (5, NULL);
+#define symbv    curfram__.varptr[0]
+#define dictv    curfram__.varptr[1]
+#define closv    curfram__.varptr[2]
+#define nstrv    curfram__.varptr[3]
+#define resv     curfram__.varptr[4]
+#define obj_symbv    ((basilysobject_ptr_t)(symbv))
+  symbv = symb_p;
+  if (basilys_magic_discr (symbv) != OBMAG_OBJECT
+      || obj_symbv->obj_len < FSYMB__LAST
+      || !basilys_is_instance_of (symbv, BASILYSG (CLASS_SYMBOL)))
+    goto fail;
+  nstrv = obj_symbv->obj_vartab[FNAMED_NAME];
+  if (basilys_magic_discr (nstrv) != OBMAG_STRING)
+    goto fail;
+  if (basilys_magic_discr (BASILYSG (TOKENIZER)) !=
+      OBMAG_OBJECT
+      || BASILYSGOB (TOKENIZER)->obj_len < FTOK__LAST
+      || !basilys_is_instance_of (BASILYSG (TOKENIZER),
+				  BASILYSG (CLASS_TOKENIZER)))
+    goto fail;
+  closv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_INTERNSYMB];
+  if (basilys_magic_discr (closv) != OBMAG_CLOSURE)
+    goto fail;
+  else
+    {
+      union basilysparam_un pararg[1];
+      memset (&pararg, 0, sizeof (pararg));
+      pararg[0].bp_aptr = (basilys_ptr_t *) & symbv;
+      resv =
+	basilysgc_apply (closv, BASILYSG (TOKENIZER), BPARSTR_PTR,
+			 pararg, "", NULL);
+      goto end;
+    }
+fail:
+  resv = NULL;
+end:;
+  BASILYS_EXITFRAME ();
+  return resv;
+#undef symbv
+#undef dictv
+#undef closv
+#undef nstrv
+#undef resv
+#undef obj_symbv
+}
+
+
+basilys_ptr_t
+basilysgc_intern_keyword (basilys_ptr_t keyw_p)
+{
+  BASILYS_ENTERFRAME (5, NULL);
+#define keywv    curfram__.varptr[0]
+#define dictv    curfram__.varptr[1]
+#define closv    curfram__.varptr[2]
+#define nstrv    curfram__.varptr[3]
+#define resv     curfram__.varptr[4]
+#define obj_keywv    ((basilysobject_ptr_t)(keywv))
+  keywv = keyw_p;
+  if (basilys_magic_discr (keywv) != OBMAG_OBJECT
+      || obj_keywv->obj_len < FSYMB__LAST
+      || !basilys_is_instance_of (keywv, BASILYSG (CLASS_KEYWORD)))
+    goto fail;
+  nstrv = obj_keywv->obj_vartab[FNAMED_NAME];
+  if (basilys_magic_discr (nstrv) != OBMAG_STRING)
+    goto fail;
+  if (basilys_magic_discr (BASILYSG (TOKENIZER)) !=
+      OBMAG_OBJECT
+      || BASILYSGOB (TOKENIZER)->obj_len < FTOK__LAST
+      || !basilys_is_instance_of (BASILYSG (TOKENIZER),
+				  BASILYSG (CLASS_TOKENIZER)))
+    goto fail;
+  closv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_INTERNKEYW];
+  if (basilys_magic_discr (closv) != OBMAG_CLOSURE)
+    goto fail;
+  else
+    {
+      union basilysparam_un pararg[1];
+      memset (&pararg, 0, sizeof (pararg));
+      pararg[0].bp_aptr = (basilys_ptr_t *) & keywv;
+      resv =
+	basilysgc_apply (closv, BASILYSG (TOKENIZER), BPARSTR_PTR,
+			 pararg, "", NULL);
+      goto end;
+    }
+fail:
+  resv = NULL;
+end:;
+  BASILYS_EXITFRAME ();
+  return resv;
+#undef symbv
+#undef dictv
+#undef closv
+#undef nstrv
+#undef resv
+#undef obj_symbv
+}
+
+
+
+
+
+
+basilys_ptr_t
+basilysgc_named_keyword (const char *nam, int create)
+{
+  int namlen = 0, ix = 0;
+  char *namdup = 0;
+  char tinybuf[130];
+  BASILYS_ENTERFRAME (4, NULL);
+#define keywv    curfram__.varptr[0]
+#define dictv    curfram__.varptr[1]
+#define closv    curfram__.varptr[2]
+#define nstrv    curfram__.varptr[3]
+  keywv = NULL;
+  dictv = NULL;
+  closv = NULL;
+  if (!nam)
+    goto end;
+  if (nam[0] == ':')
+    nam++;
+  namlen = strlen (nam);
+  memset (tinybuf, 0, sizeof (tinybuf));
+  if (namlen < (int) sizeof (tinybuf) - 2)
+    namdup = strcpy (tinybuf, nam);
+  else
+    namdup = strcpy (xcalloc (namlen + 1, 1), nam);
+  for (ix = 0; ix < namlen; ix++)
+    if (ISALPHA (namdup[ix]))
+      namdup[ix] = TOUPPER (namdup[ix]);
+  gcc_assert (basilys_magic_discr (BASILYSG (CLASS_TOKENIZER))
+	      == OBMAG_OBJECT);
+  gcc_assert (basilys_magic_discr (BASILYSG (TOKENIZER)) == OBMAG_OBJECT);
+  if (basilys_is_instance_of
+      (BASILYSG (TOKENIZER), BASILYSG (CLASS_TOKENIZER))
+      && BASILYSGOB (TOKENIZER)->obj_len >= FTOK__LAST)
+    {
+      dictv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_KEYWDICT];
+      if (basilys_magic_discr (dictv) == OBMAG_MAPSTRINGS)
+	keywv = basilys_get_mapstrings (dictv, namdup);
+      if (keywv || !create)
+	goto end;
+      closv = BASILYSGOB (TOKENIZER)->obj_vartab[FTOK_ADDKEYW];
+      if (basilys_magic_discr (closv) == OBMAG_CLOSURE)
+	{
+	  union basilysparam_un pararg[1];
+	  memset (&pararg, 0, sizeof (pararg));
+	  nstrv = basilysgc_new_string (BASILYSGOB (DISCR_STRING), namdup);
+	  pararg[0].bp_aptr = (basilys_ptr_t *) & nstrv;
+	  keywv =
+	    basilysgc_apply (closv, BASILYSG (TOKENIZER), BPARSTR_PTR,
+			     pararg, "", NULL);
+	  goto end;
+	}
+    }
+end:;
+  if (namdup && namdup != tinybuf)
+    free (namdup);
+  BASILYS_EXITFRAME ();
+  return keywv;
+#undef keywv
+#undef dictv
+#undef closv
+#undef nstrv
+}
+
+
+
+static basilys_ptr_t
+readsexpr (struct reading_st *rd, int endc)
+{
+  int c = 0, lineno = rd->rlineno;
+  BASILYS_ENTERFRAME (3, NULL);
+#define sexprv  curfram__.varptr[0]
+#define contv   curfram__.varptr[1]
+#define locmixv curfram__.varptr[2]
+  if (!endc || rdeof ())
+    READ_ERROR ("eof in s-expr (lin%d)", lineno);
+  c = skipspace_getc (rd);
+  contv = readseqlist (rd, endc);
+  sexprv = makesexpr (rd, lineno, contv);
+  BASILYS_EXITFRAME ();
+  return sexprv;
+#undef sexprv
+#undef contv
+#undef locmixv
+}
+
+
+static basilys_ptr_t
+readassoc (struct reading_st *rd)
+{
+  int sz = 0, c = 0, ln = 0, pos = 0;
+  BASILYS_ENTERFRAME (3, NULL);
+#define mapv  curfram__.varptr[0]
+#define attrv curfram__.varptr[1]
+#define valv   curfram__.varptr[2]
+  /* maybe read the size */
+  if (rdcurc () == '/')
+    {
+      sscanf (&rdcurc (), "/%d%n", &sz, &pos);
+      if (pos > 0)
+	rd->rcol += pos;
+    };
+  if (sz > BASILYS_MAXLEN)
+    sz = BASILYS_MAXLEN;
+  else if (sz < 0)
+    sz = 2;
+  mapv = basilysgc_new_mapobjects (BASILYSGOB (DISCR_MAPOBJECTS), sz);
+  c = skipspace_getc (rd);
+  while (c != '}' && !rdeof ())
+    {
+      bool gotat = FALSE, gotva = FALSE;
+      ln = rd->rlineno;
+      attrv = readval (rd, &gotat);
+      if (!gotat || !attrv || basilys_magic_discr (attrv) != OBMAG_OBJECT)
+	READ_ERROR ("bad attribute in mapoobject line %d", ln);
+      c = skipspace_getc (rd);
+      if (c != '=')
+	READ_ERROR ("expected equal = after attribute but got %c",
+		    ISPRINT (c) ? c : ' ');
+      rdnext ();
+      ln = rd->rlineno;
+      valv = readval (rd, &gotva);
+      if (!valv)
+	READ_ERROR ("null or missing value in mapobject line %d", ln);
+      c = skipspace_getc (rd);
+      if (c == '.')
+	c = skipspace_getc (rd);
+    }
+  if (c == '}')
+    rdnext ();
+  BASILYS_EXITFRAME ();
+  return mapv;
+#undef mapv
+#undef attrv
+#undef valv
+}
+
+
+
+static basilys_ptr_t
+readstring (struct reading_st *rd)
+{
+  int c = 0;
+  int nbesc = 0;
+  char *cstr = 0, *endc = 0;
+  BASILYS_ENTERFRAME (1, NULL);
+#define strv   curfram__.varptr[0]
+#define str_strv  ((struct basilysstring_st*)(strv))
+  while ((c = rdcurc ()) != '"' && !rdeof ())
+    {
+      if (c != '\\')
+	{
+	  obstack_1grow (&bstring_obstack, (char) c);
+	  rdnext ();
+	}
+      else
+	{
+	  rdnext ();
+	  c = rdcurc ();
+	  nbesc++;
+	  switch (c)
+	    {
+	    case 'a':
+	      c = '\a';
+	      rdnext ();
+	      break;
+	    case 'b':
+	      c = '\b';
+	      rdnext ();
+	      break;
+	    case 't':
+	      c = '\t';
+	      rdnext ();
+	      break;
+	    case 'n':
+	      c = '\n';
+	      rdnext ();
+	      break;
+	    case 'v':
+	      c = '\v';
+	      rdnext ();
+	      break;
+	    case 'f':
+	      c = '\f';
+	      rdnext ();
+	      break;
+	    case 'r':
+	      c = '\r';
+	      rdnext ();
+	      break;
+	    case '"':
+	      c = '\"';
+	      rdnext ();
+	      break;
+	    case '\n':
+	    case '\r':
+	      rdnext ();
+	      continue;
+	    case ' ':
+	      c = ' ';
+	      rdnext ();
+	      break;
+	    case 'x':
+	      rdnext ();
+	      c = (char) strtol (&rdcurc (), &endc, 16);
+	      if (c == 0 && endc <= &rdcurc ())
+		READ_ERROR ("illegal hex \\x escape in string %.20s",
+			    &rdcurc ());
+	      if (*endc == ';')
+		endc++;
+	      rd->rcol += endc - &rdcurc ();
+	      break;
+	    default:
+	      READ_ERROR ("illegal escape sequence %.3s in string",
+			  &rdcurc () - 1);
+	    }
+	  obstack_1grow (&bstring_obstack, (char) c);
+	}
+    }
+  if (c == '"')
+    rdnext ();
+  else
+    READ_ERROR ("unterminated string %.20s", &rdcurc ());
+  obstack_1grow (&bstring_obstack, (char) 0);
+  cstr = XOBFINISH (&bstring_obstack, char *);
+  strv = basilysgc_new_string (BASILYSGOB (DISCR_STRING), cstr);
+  if (nbesc > 0)
+    debugeprintf ("read at line %d escaped string '%s'", rd->rlineno, cstr);
+  obstack_free (&bstring_obstack, cstr);
+  BASILYS_EXITFRAME ();
+  return strv;
+#undef strv
+#undef str_strv
+}
+
+
+static basilys_ptr_t
+readhashescape (struct reading_st *rd)
+{
+  int c = 0;
+  BASILYS_ENTERFRAME (4, NULL);
+#define readv  curfram__.varptr[0]
+#define compv  curfram__.varptr[1]
+#define listv  curfram__.varptr[2]
+#define pairv  curfram__.varptr[3]
+  readv = NULL;
+  c = rdcurc ();
+  if (!c || rdeof ())
+    READ_ERROR ("eof in hashescape %.20s", &rdcurc ());
+  if (c == '\\')
+    {
+      rdnext ();
+      if (ISALPHA (rdcurc ()) && rdcurc () != 'x' && ISALPHA (rdfollowc (1)))
+	{
+	  char *nam = readsimplename (rd);
+	  c = 0;
+	  if (!strcmp (nam, "nul"))
+	    c = 0;
+	  else if (!strcmp (nam, "alarm"))
+	    c = '\a';
+	  else if (!strcmp (nam, "backspace"))
+	    c = '\b';
+	  else if (!strcmp (nam, "tab"))
+	    c = '\t';
+	  else if (!strcmp (nam, "linefeed"))
+	    c = '\n';
+	  else if (!strcmp (nam, "vtab"))
+	    c = '\v';
+	  else if (!strcmp (nam, "page"))
+	    c = '\f';
+	  else if (!strcmp (nam, "return"))
+	    c = '\r';
+	  else if (!strcmp (nam, "space"))
+	    c = ' ';
+	  /* won't work on non ASCII or ISO or Unicode host, but we don't care */
+	  else if (!strcmp (nam, "delete"))
+	    c = 0xff;
+	  else if (!strcmp (nam, "esc"))
+	    c = 0x1b;
+	  else
+	    READ_ERROR ("invalid char escape %s", nam);
+	  obstack_free (&bname_obstack, nam);
+	char_escape:
+	  readv = basilysgc_new_int (BASILYSGOB (DISCR_CHARINTEGER), c);
+	}
+      else if (rdcurc () == 'x' && ISXDIGIT (rdfollowc (1)))
+	{
+	  char *endc = 0;
+	  rdnext ();
+	  c = strtol (&rdcurc (), &endc, 16);
+	  if (c == 0 && endc <= &rdcurc ())
+	    READ_ERROR ("illigal hex #\\x escape in char %.20s", &rdcurc ());
+	  rd->rcol += endc - &rdcurc ();
+	  goto char_escape;
+	}
+      else if (ISPRINT (rdcurc ()))
+	{
+	  c = rdcurc ();
+	  rdnext ();
+	  goto char_escape;
+	}
+      else
+	READ_ERROR ("unrecognized char escape #\\%s", &rdcurc ());
+    }
+  else if (c == '(')
+    {
+      int ln = 0, ix = 0;
+      listv = readseqlist (rd, ')');
+      ln = basilys_list_length (listv);
+      gcc_assert (ln >= 0);
+      readv = basilysgc_new_multiple (BASILYSGOB (DISCR_MULTIPLE), ln);
+      for ((ix = 0), (pairv =
+		      ((struct basilyslist_st *) (listv))->first);
+	   ix < ln && basilys_magic_discr (pairv) == OBMAG_PAIR;
+	   pairv = ((struct basilyspair_st *) (pairv))->tl)
+	((struct basilysmultiple_st *) (readv))->
+	  tabval[ix++] = ((struct basilyspair_st *) (pairv))->hd;
+      basilysgc_touch (readv);
+    }
+  else if (c == '[')
+    {
+      /* a basilys extension #[ .... ] for lists */
+      readv = readseqlist (rd, ']');
+    }
+  else if ((c == 'b' || c == 'B') && ISDIGIT (rdfollowc (1)))
+    {
+      /* binary number */
+      char *endc = 0;
+      long n = 0;
+      rdnext ();
+      n = strtol (&rdcurc (), &endc, 2);
+      if (n == 0 && endc <= &rdcurc ())
+	READ_ERROR ("bad binary number %s", endc);
+      readv = basilysgc_new_int (BASILYSGOB (DISCR_INTEGER), n);
+    }
+  else if ((c == 'o' || c == 'O') && ISDIGIT (rdfollowc (1)))
+    {
+      /* octal number */
+      char *endc = 0;
+      long n = 0;
+      rdnext ();
+      n = strtol (&rdcurc (), &endc, 8);
+      if (n == 0 && endc <= &rdcurc ())
+	READ_ERROR ("bad octal number %s", endc);
+      readv = basilysgc_new_int (BASILYSGOB (DISCR_INTEGER), n);
+    }
+  else if ((c == 'd' || c == 'D') && ISDIGIT (rdfollowc (1)))
+    {
+      /* decimal number */
+      char *endc = 0;
+      long n = 0;
+      rdnext ();
+      n = strtol (&rdcurc (), &endc, 10);
+      if (n == 0 && endc <= &rdcurc ())
+	READ_ERROR ("bad decimal number %s", endc);
+      readv = basilysgc_new_int (BASILYSGOB (DISCR_INTEGER), n);
+    }
+  else if ((c == 'x' || c == 'x') && ISDIGIT (rdfollowc (1)))
+    {
+      /* hex number */
+      char *endc = 0;
+      long n = 0;
+      rdnext ();
+      n = strtol (&rdcurc (), &endc, 16);
+      if (n == 0 && endc <= &rdcurc ())
+	READ_ERROR ("bad octal number %s", endc);
+      readv = basilysgc_new_int (BASILYSGOB (DISCR_INTEGER), n);
+    }
+  else if (c == '+' && ISALPHA (rdfollowc (1)))
+    {
+      bool gotcomp = FALSE;
+      char *nam = 0;
+      nam = readsimplename (rd);
+      compv = readval (rd, &gotcomp);
+      if (!strcmp (nam, "BASILYS"))
+	readv = compv;
+      else
+	readv = readval (rd, &gotcomp);
+    }
+  else
+    READ_ERROR ("invalid escape %.20s", &rdcurc ());
+  BASILYS_EXITFRAME ();
+  return readv;
+#undef readv
+#undef listv
+#undef compv
+#undef pairv
+}
+
+
+
+static basilys_ptr_t
+readval (struct reading_st *rd, bool * pgot)
+{
+  int c = 0;
+  char *nam = 0;
+  BASILYS_ENTERFRAME (4, NULL);
+#define readv   curfram__.varptr[0]
+#define compv   curfram__.varptr[1]
+#define seqv    curfram__.varptr[2]
+#define altv    curfram__.varptr[3]
+  readv = NULL;
+  c = skipspace_getc (rd);
+  /*   debugeprintf ("start readval line %d col %d char %c", rd->rlineno, rd->rcol,
+     ISPRINT (c) ? c : ' '); */
+  if (ISDIGIT (c)
+      || ((c == '-' || c == '+')
+	  && (ISDIGIT (rdfollowc (1)) || rdfollowc (1) == '%'
+	      || rdfollowc (1) == '|')))
+    {
+      long num = 0;
+      num = readsimplelong (rd);
+      readv =
+	basilysgc_new_int ((basilysobject_ptr_t) BASILYSGOB (DISCR_INTEGER),
+			   num);
+      *pgot = TRUE;
+      goto end;
+    }				/* end if ISDIGIT or '-' or '+' */
+  else if (c == '"')
+    {
+      rdnext ();
+      readv = readstring (rd);
+      *pgot = TRUE;
+      goto end;
+    }				/* end if '"' */
+  else if (c == '(')
+    {
+      rdnext ();
+      if (rdcurc () == ')')
+	{
+	  rdnext ();
+	  readv = NULL;
+	  *pgot = TRUE;
+	  goto end;
+	}
+      readv = readsexpr (rd, ')');
+      *pgot = TRUE;
+      goto end;
+    }				/* end if '(' */
+  else if (c == '[')
+    {
+      rdnext ();
+      readv = readsexpr (rd, ']');
+      *pgot = TRUE;
+      goto end;
+    }				/* end if '(' */
+  else if (c == '{')
+    {
+      rdnext ();
+      readv = readassoc (rd);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (c == '#')
+    {
+      rdnext ();
+      c = rdcurc ();
+      readv = readhashescape (rd);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (c == '\'')
+    {
+      int lineno = rd->rlineno;
+      bool got = false;
+      rdnext ();
+      compv = readval (rd, &got);
+      if (!got)
+	READ_ERROR ("expecting value after quote %.20s", &rdcurc ());
+      seqv = basilysgc_new_list (BASILYSGOB (DISCR_LIST));
+      altv = basilysgc_named_symbol ("quote", BASILYS_CREATE);
+      basilysgc_append_list (seqv, altv);
+      basilysgc_append_list (seqv, compv);
+      readv = makesexpr (rd, lineno, seqv);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (c == '`')
+    {
+      int lineno = rd->rlineno;
+      bool got = false;
+      rdnext ();
+      compv = readval (rd, &got);
+      if (!got)
+	READ_ERROR ("expecting value after backquote %.20s", &rdcurc ());
+      seqv = basilysgc_new_list (BASILYSGOB (DISCR_LIST));
+      altv = basilysgc_named_symbol ("backquote", BASILYS_CREATE);
+      basilysgc_append_list (seqv, altv);
+      basilysgc_append_list (seqv, compv);
+      readv = makesexpr (rd, lineno, seqv);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (c == ',')
+    {
+      int lineno = rd->rlineno;
+      bool got = false;
+      rdnext ();
+      compv = readval (rd, &got);
+      if (!got)
+	READ_ERROR ("expecting value after comma %.20s", &rdcurc ());
+      seqv = basilysgc_new_list (BASILYSGOB (DISCR_LIST));
+      altv = basilysgc_named_symbol ("comma", BASILYS_CREATE);
+      basilysgc_append_list (seqv, altv);
+      basilysgc_append_list (seqv, compv);
+      readv = makesexpr (rd, lineno, seqv);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (c == ':')
+    {
+      nam = readsimplename (rd);
+      readv = basilysgc_named_keyword (nam, BASILYS_CREATE);
+      if (!readv)
+	READ_ERROR ("unknown named keyword %s", nam);
+      *pgot = TRUE;
+      goto end;
+    }
+  else if (ISALPHA (c) || strchr (EXTRANAMECHARS, c) != NULL)
+    {
+      nam = readsimplename (rd);
+      readv = basilysgc_named_symbol (nam, BASILYS_CREATE);
+      *pgot = TRUE;
+      goto end;
+    }
+  else
+    {
+      if (c >= 0)
+	rdback ();
+      readv = NULL;
+    }
+end:
+  BASILYS_EXITFRAME ();
+  if (nam)
+    {
+      *nam = 0;
+      obstack_free (&bname_obstack, nam);
+    };
+  return readv;
+#undef readv
+#undef compv
+#undef seqv
+#undef altv
+}
+
+
+
+basilys_ptr_t
+basilysgc_read_file (const char *filnam)
+{
+  struct reading_st rds;
+  FILE *fil = 0;
+  char *filpath = 0, *filnamdup = 0;
+  int filnamlen = 0;
+  char tinybuf[140];
+  struct reading_st *rd = 0;
+  BASILYS_ENTERFRAME (4, NULL);
+#define genv      curfram__.varptr[0]
+#define valv      curfram__.varptr[1]
+#define filnamv   curfram__.varptr[2]
+#define seqv      curfram__.varptr[3]
+  memset (&rds, 0, sizeof (rds));
+  memset (tinybuf, 0, sizeof (tinybuf));
+  if (!filnam)
+    goto end;
+  debugeprintf ("basilysgc_read_file filnam %s", filnam);
+  filnamlen = strlen (filnam);
+  if (filnamlen < (int) sizeof (tinybuf) - 1)
+    filnamdup = strcpy (tinybuf, filnam);
+  else
+    filnamdup = strcpy (xcalloc (filnamlen + 1, 1), filnam);
+  fil = fopen (filnamdup, "rt");
+  if (!fil)
+    {
+      filpath = update_path (filnamdup, "GCC");
+      fil = fopen (filpath, "rt");
+    }
+  if (!fil)
+    fatal_error ("cannot open basilys file %s - %m", filnamdup);
+  /*  debugeprintf ("starting loading file %s", filnamdup); */
+  rds.rfil = fil;
+  rds.rpath = filnamdup;
+  rds.rlineno = 0;
+  rd = &rds;
+  filnamv = basilysgc_new_string (BASILYSGOB (DISCR_STRING), filnamdup);
+  rds.rpfilnam = (basilys_ptr_t *) & filnamv;
+  rds.rpgenv = (basilys_ptr_t *) & genv;
+  seqv = basilysgc_new_list (BASILYSGOB (DISCR_LIST));
+  while (!rdeof ())
+    {
+      bool got = FALSE;
+      skipspace_getc (rd);
+      if (rdeof ())
+	break;
+      valv = readval (rd, &got);
+      if (!got)
+	READ_ERROR ("no value read %.20s", &rdcurc ());
+      basilysgc_append_list (seqv, valv);
+    };
+  rd = 0;
+end:
+  BASILYS_EXITFRAME ();
+  if (filpath)
+    free (filpath);
+  if (filnamdup && filnamdup != tinybuf)
+    free (filnamdup);
+  return seqv;
+#undef vecshv
+#undef genv
+#undef filnamv
+#undef seqv
+}
+
+
+static void
+do_initial_command (void)
+{
+  BASILYS_ENTERFRAME (4, NULL);
+#define dictv     curfram__.varptr[0]
+#define closv     curfram__.varptr[1]
+#define cstrv     curfram__.varptr[2]
+  debugeprintf ("do_initial_command command_string %s",
+		basilys_command_string);
+  if (basilys_magic_discr
+      ((BASILYSG (INITIAL_COMMAND_DISPATCHER))) != OBMAG_OBJECT
+      || BASILYSGOB (INITIAL_COMMAND_DISPATCHER)->obj_len <
+      FCMDIS__LAST
+      || !BASILYSGOB (INITIAL_COMMAND_DISPATCHER)->obj_vartab
+      || !basilys_command_string || !basilys_command_string[0])
+    goto end;
+  dictv = BASILYSGOB (INITIAL_COMMAND_DISPATCHER)->obj_vartab[FCMDIS_FUNDICT];
+  debugeprintf ("do_initial_command dictv=%p", dictv);
+  if (basilys_magic_discr (dictv) != OBMAG_MAPSTRINGS)
+    goto end;
+  closv = basilys_get_mapstrings (dictv, basilys_command_string);
+  debugeprintf ("do_initial_command closv=%p", closv);
+  if (basilys_magic_discr (closv) != OBMAG_CLOSURE)
+    goto end;
+  debugeprintf ("do_initial_command argument_string %s",
+		basilys_argument_string);
+  {
+    union basilysparam_un pararg[1];
+    memset (pararg, 0, sizeof (pararg));
+    cstrv =
+      basilysgc_new_string (BASILYSGOB (DISCR_STRING),
+			    basilys_argument_string);
+    pararg[0].bp_aptr = (basilys_ptr_t *) & cstrv;
+    debugeprintf ("do_initial_command before apply closv %p", closv);
+    (void) basilysgc_apply (closv,
+			    BASILYSG
+			    (INITIAL_COMMAND_DISPATCHER),
+			    BPARSTR_PTR, pararg, "", NULL);
+    debugeprintf ("do_initial_command after apply closv %p", closv);
+  }
+end:;
+  debugeprintf ("do_initial_command end %s", basilys_argument_string);
+  BASILYS_EXITFRAME ();
+#undef dictv
+#undef closv
+#undef cstrv
+}
+
+
+
+/****
+ * Initialize basilys. Called from toplevel.c before pass management.
+ ****/
+void
+basilys_initialize (void)
+{
+  static int inited;
+  long seed;
+  const char *pc;
+  const char *randomseed = 0;
+  if (inited)
+    return;
+#if ENABLE_CHECKING
+#warning basile debogue temporaire
+  {
+    char nom_debogue[200];
+    snprintf (nom_debogue, sizeof (nom_debogue),
+	      "%s/tmp/debughack_basilys", getenv ("HOME"));
+    debughack_file = fopen (nom_debogue, "w");
+    if (debughack_file)
+      {
+	time_t maintenant = 0;
+	time (&maintenant);
+	fprintf (debughack_file,
+		 "# fichier %s pid %d du %s\n compilé %s @ %s",
+		 nom_debogue, (int) getpid (), ctime (&maintenant),
+		 __DATE__, __TIME__);
+	fflush (debughack_file);
+      }
+  }
+#endif
+  seed = 0;
+  randomseed = get_random_seed (false);
+  gcc_assert (randomseed != (char *) 0);
+  gcc_assert (BASILYS_ALIGN == sizeof (void *)
+	      || BASILYS_ALIGN == 2 * sizeof (void *)
+	      || BASILYS_ALIGN == 4 * sizeof (void *));
+  inited = 1;
+  ggc_collect ();
+  obstack_init (&bstring_obstack);
+  obstack_init (&bname_obstack);
+  for (pc = randomseed; *pc; pc++)
+    seed ^= (seed << 6) + (*pc);
+  srand48_r ((long) seed, &randata);
+  gcc_assert (!basilys_curalz);
+  {
+    size_t wantedwords = MINOR_SIZE_KILOWORD * 4096;
+    if (wantedwords < (1 << 20))
+      wantedwords = (1 << 20);
+    gcc_assert (basilys_startalz == NULL && basilys_endalz == NULL);
+    gcc_assert (wantedwords * sizeof (void *) >
+		300 * BGLOB__LASTGLOB * sizeof (struct basilysobject_st));
+    basilys_curalz = basilys_startalz =
+      xcalloc (sizeof (void *), wantedwords);
+    basilys_endalz = (char *) basilys_curalz + wantedwords * sizeof (void *);
+    basilys_storalz = ((void **) basilys_endalz) - 2;
+    basilys_newspeclist = NULL;
+    basilys_oldspeclist = NULL;
+  }
+  if (!basilys_init_string)
+    fatal_error ("no initial basilys file specified thru -fbasilys-init");
+  debugeprintf
+    ("basilys_initialize before compile_dyn init_string=%s",
+     basilys_init_string);
+  basilysgc_compile_dyn ((basilys_ptr_t) 0, basilys_init_string);
+  debugeprintf
+    ("basilys_initialize before initial_command command_string=%s",
+     basilys_command_string);
+#if ENABLE_CHECKING
+#warning basile debogue temporaire ici
+  if (debughack_file)
+    {
+      fprintf (debughack_file,
+	       "%s:%d apres initial_command command_string=%s\n",
+	       basename (__FILE__), __LINE__, basilys_command_string);
+      fflush (debughack_file);
+    }
+#endif
+  if (basilys_magic_discr
+      ((BASILYSG (INITIAL_COMMAND_DISPATCHER))) == OBMAG_OBJECT
+      && BASILYSGOB (INITIAL_COMMAND_DISPATCHER)->obj_len >=
+      FCMDIS__LAST && basilys_command_string)
+    {
+      gcc_assert (dump_file == (FILE *) 0);
+      if (flag_basilys_debug)
+	{
+	  fflush (stderr);
+	  dump_file = stderr;
+	  fflush (stderr);
+	}
+      do_initial_command ();
+      exit_after_options = 1;
+      debugeprintf
+	("basilys_initialize after do_initial_command (will exit after options) command_string %s",
+	 basilys_command_string);
+      if (dump_file)
+	{
+	  debugeprintf ("basilys_initialize dump_file cleared was %p",
+			(void *) dump_file);
+	  fflush (dump_file);
+	  dump_file = 0;
+	}
+    }
+  debugeprintf ("basilys_initialize ended with %ld GarbColl, %ld fullGc",
+		basilys_nb_garbcoll, basilys_nb_full_garbcoll);
+#if ENABLE_CHECKING
+#warning basile debogue temporaire final
+  if (debughack_file)
+    {
+      fprintf (debughack_file, "%s:%d fini compilé %s @ %s\n",
+	       basename (__FILE__), __LINE__, __DATE__, __TIME__);
+      fclose (debughack_file);
+      debughack_file = NULL;
+    }
+#endif
+}
+
+
+
+
+
+
+static void
+discr_out (struct debugprint_basilys_st *dp, basilysobject_ptr_t odiscr)
+{
+  int dmag = basilys_magic_discr ((void *) odiscr);
+  struct basilysstring_st *str = NULL;
+  if (dmag != OBMAG_OBJECT)
+    {
+      fprintf (dp->dfil, "?discr@%p?", (void *) odiscr);
+      return;
+    }
+  if (odiscr->obj_len >= FNAMED__LAST && odiscr->obj_vartab)
+    {
+      str = (void *) odiscr->obj_vartab[FNAMED_NAME];
+      if (basilys_magic_discr ((void *) str) != OBMAG_STRING)
+	str = NULL;
+    }
+  if (!str)
+    {
+      fprintf (dp->dfil, "?odiscr/%d?", odiscr->obj_hash);
+      return;
+    }
+  fprintf (dp->dfil, "#%s", str->val);
+}
+
+
+static void
+nl_debug_out (struct debugprint_basilys_st *dp, int depth)
+{
+  int i;
+  putc ('\n', dp->dfil);
+  for (i = 0; i < depth; i++)
+    putc (' ', dp->dfil);
+}
+
+static void
+skip_debug_out (struct debugprint_basilys_st *dp, int depth)
+{
+  if (dp->dcount % 4 == 0)
+    nl_debug_out (dp, depth);
+  else
+    putc (' ', dp->dfil);
+}
+
+
+static bool
+is_named_obj (basilysobject_ptr_t ob)
+{
+  struct basilysstring_st *str = 0;
+  if (basilys_magic_discr ((void *) ob) != OBMAG_OBJECT)
+    return FALSE;
+  if (ob->obj_len < FNAMED__LAST || !ob->obj_vartab)
+    return FALSE;
+  str = (void *) ob->obj_vartab[FNAMED_NAME];
+  if (basilys_magic_discr ((void *) str) != OBMAG_STRING)
+    return FALSE;
+  if (basilys_is_instance_of ((basilys_ptr_t) ob, BASILYSG (CLASS_NAMED)))
+    return TRUE;
+  return FALSE;
+}
+
+static void
+debug_outstr (struct debugprint_basilys_st *dp, const char *str)
+{
+  int nbclin = 0;
+  const char *pc;
+  for (pc = str; *pc; pc++)
+    {
+      nbclin++;
+      if (nbclin > 60 && strlen (pc) > 5)
+	{
+	  if (ISSPACE (*pc) || ISPUNCT (*pc) || nbclin > 72)
+	    {
+	      fputs ("\\\n", dp->dfil);
+	      nbclin = 0;
+	    }
+	}
+      switch (*pc)
+	{
+	case '\n':
+	  fputs ("\\n", dp->dfil);
+	  break;
+	case '\r':
+	  fputs ("\\r", dp->dfil);
+	  break;
+	case '\t':
+	  fputs ("\\t", dp->dfil);
+	  break;
+	case '\v':
+	  fputs ("\\v", dp->dfil);
+	  break;
+	case '\f':
+	  fputs ("\\f", dp->dfil);
+	  break;
+	case '\"':
+	  fputs ("\\q", dp->dfil);
+	  break;
+	case '\'':
+	  fputs ("\\a", dp->dfil);
+	  break;
+	default:
+	  if (ISPRINT (*pc))
+	    putc (*pc, dp->dfil);
+	  else
+	    fprintf (dp->dfil, "\\x%02x", (*pc) & 0xff);
+	  break;
+	}
+    }
+}
+
+
+void
+basilys_debug_out (struct debugprint_basilys_st *dp,
+		   basilys_ptr_t ptr, int depth)
+{
+  int mag = basilys_magic_discr (ptr);
+  int ix;
+  if (!dp->dfil)
+    return;
+  dp->dcount++;
+  switch (mag)
+    {
+    case 0:
+      {
+	if (ptr)
+	  fprintf (dp->dfil, "??@%p??", (void *) ptr);
+	else
+	  fputs ("@@", dp->dfil);
+	break;
+      }
+    case OBMAG_OBJECT:
+      {
+	struct basilysobject_st *p = (void *) ptr;
+	bool named = is_named_obj (p);
+	fputs ("%", dp->dfil);
+	discr_out (dp, p->obj_class);
+	fprintf (dp->dfil, "/L%dH%d", p->obj_len, p->obj_hash);
+	if (p->obj_num)
+	  fprintf (dp->dfil, "N%d", p->obj_num);
+	if (named)
+	  fprintf (dp->dfil, "<#%s>",
+		   ((struct basilysstring_st *) (p->
+						 obj_vartab
+						 [FNAMED_NAME]))->val);
+	if ((!named || depth == 0) && depth < dp->dmaxdepth)
+	  {
+	    fputs ("[", dp->dfil);
+	    if (p->obj_vartab)
+	      for (ix = 0; ix < p->obj_len; ix++)
+		{
+		  if (ix > 0)
+		    skip_debug_out (dp, depth);
+		  basilys_debug_out (dp, p->obj_vartab[ix], depth + 1);
+		}
+	    fputs ("]", dp->dfil);
+	  }
+	else if (!named)
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_MULTIPLE:
+      {
+	struct basilysmultiple_st *p = (void *) ptr;
+	fputs ("*", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fputs ("(", dp->dfil);
+	    for (ix = 0; ix < (int) p->nbval; ix++)
+	      {
+		if (ix > 0)
+		  skip_debug_out (dp, depth);
+		basilys_debug_out (dp, p->tabval[ix], depth + 1);
+	      }
+	    fputs (")", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_STRING:
+      {
+	struct basilysstring_st *p = (void *) ptr;
+	fputs ("!", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fputs ("\"", dp->dfil);
+	    debug_outstr (dp, p->val);
+	    fputs ("\"", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_INT:
+      {
+	struct basilysint_st *p = (void *) ptr;
+	fputs ("!", dp->dfil);
+	discr_out (dp, p->discr);
+	fprintf (dp->dfil, "#%ld", p->val);
+	break;
+      }
+    case OBMAG_MIXINT:
+      {
+	struct basilysmixint_st *p = (void *) ptr;
+	fputs ("!", dp->dfil);
+	discr_out (dp, p->discr);
+	fprintf (dp->dfil, "[#%ld&", p->intval);
+	basilys_debug_out (dp, p->ptrval, depth + 1);
+	fputs ("]", dp->dfil);
+	break;
+      }
+    case OBMAG_LIST:
+      {
+	struct basilyslist_st *p = (void *) ptr;
+	fputs ("!", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    int ln = basilys_list_length ((void *) p);
+	    struct basilyspair_st *pr;
+	    if (ln > 2)
+	      fprintf (dp->dfil, "[/%d ", ln);
+	    else
+	      fputs ("[", dp->dfil);
+	    for (pr = p->first;
+		 pr && basilys_magic_discr ((void *) pr) == OBMAG_PAIR;
+		 pr = pr->tl)
+	      {
+		basilys_debug_out (dp, pr->hd, depth + 1);
+		if (pr->tl)
+		  skip_debug_out (dp, depth);
+	      }
+	    fputs ("]", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_MAPSTRINGS:
+      {
+	struct basilysmapstrings_st *p = (void *) ptr;
+	fputs ("|", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    int ln = basilys_primtab[p->lenix];
+	    fprintf (dp->dfil, "{~%d/", p->count);
+	    if (p->entab)
+	      for (ix = 0; ix < ln; ix++)
+		{
+		  const char *ats = p->entab[ix].e_at;
+		  if (!ats || ats == HTAB_DELETED_ENTRY)
+		    continue;
+		  nl_debug_out (dp, depth);
+		  fputs ("'", dp->dfil);
+		  debug_outstr (dp, ats);
+		  fputs ("' = ", dp->dfil);
+		  basilys_debug_out (dp, p->entab[ix].e_va, depth + 1);
+		  fputs (";", dp->dfil);
+		}
+	    fputs (" ~}", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_MAPOBJECTS:
+      {
+	struct basilysmapobjects_st *p = (void *) ptr;
+	fputs ("|", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    int ln = basilys_primtab[p->lenix];
+	    fprintf (dp->dfil, "{%d/", p->count);
+	    if (p->entab)
+	      for (ix = 0; ix < ln; ix++)
+		{
+		  basilysobject_ptr_t atp = p->entab[ix].e_at;
+		  if (!atp || atp == HTAB_DELETED_ENTRY)
+		    continue;
+		  nl_debug_out (dp, depth);
+		  basilys_debug_out (dp, (void *) atp, dp->dmaxdepth);
+		  fputs ("' = ", dp->dfil);
+		  basilys_debug_out (dp, p->entab[ix].e_va, depth + 1);
+		  fputs (";", dp->dfil);
+		}
+	    fputs (" }", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_CLOSURE:
+      {
+	struct basilysclosure_st *p = (void *) ptr;
+	fputs ("!.", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fprintf (dp->dfil, "[. rout=");
+	    basilys_debug_out (dp, (void *) p->rout, depth + 1);
+	    skip_debug_out (dp, depth);
+	    fprintf (dp->dfil, " /%d: ", p->nbval);
+	    for (ix = 0; ix < (int) p->nbval; ix++)
+	      {
+		if (ix > 0)
+		  skip_debug_out (dp, depth);
+		basilys_debug_out (dp, p->tabval[ix], depth + 1);
+	      }
+	    fputs (".]", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_ROUTINE:
+      {
+	struct basilysroutine_st *p = (void *) ptr;
+	fputs ("!:", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fprintf (dp->dfil, ".%s[:/%d ", p->routdescr, p->nbval);
+	    for (ix = 0; ix < (int) p->nbval; ix++)
+	      {
+		if (ix > 0)
+		  skip_debug_out (dp, depth);
+		basilys_debug_out (dp, p->tabval[ix], depth + 1);
+	      }
+	    fputs (":]", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_STRBUF:
+      {
+	struct basilysstrbuf_st *p = (void *) ptr;
+	fputs ("!`", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fprintf (dp->dfil, "[`buflen=%ld ", basilys_primtab[p->buflenix]);
+	    gcc_assert (p->bufstart <= p->bufend
+			&& p->bufend < basilys_primtab[p->buflenix]);
+	    fprintf (dp->dfil, "bufstart=%u bufend=%u buf='",
+		     p->bufstart, p->bufend);
+	    if (p->bufzn)
+	      debug_outstr (dp, p->bufzn + p->bufstart);
+	    fputs ("' `]", dp->dfil);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	break;
+      }
+    case OBMAG_PAIR:
+      {
+	struct basilyspair_st *p = (void *) ptr;
+	fputs ("[pair:", dp->dfil);
+	discr_out (dp, p->discr);
+	if (depth < dp->dmaxdepth)
+	  {
+	    fputs ("hd:", dp->dfil);
+	    basilys_debug_out (dp, p->hd, depth + 1);
+	    fputs ("; ti:", dp->dfil);
+	    basilys_debug_out (dp, (basilys_ptr_t) p->tl, depth + 1);
+	  }
+	else
+	  fputs ("..", dp->dfil);
+	fputs ("]", dp->dfil);
+	break;
+      }
+    case OBMAG_TRIPLE:
+    case OBMAG_TREE:
+    case OBMAG_BASICBLOCK:
+    case OBMAG_EDGE:
+    case OBMAG_MAPTREES:
+    case OBMAG_MAPBASICBLOCKS:
+    case OBMAG_MAPEDGES:
+    case OBMAG_DECAY:
+      fatal_error ("debug_out unimplemented magic %d", mag);
+    default:
+      gcc_unreachable ();
+    }
+}
+
+
+/*************************************************************************
+ * GATE & PASS should be moved in another file 
+ *************************************************************************/
+
+
+/* just dump the cgraph node to understand what is it about */
+static void
+dump_cgraph_basilys (int passcount)
+{
+  struct cgraph_node *cgr_fun = 0;
+  tree tr_body = 0;
+  dbgprintf ("start dump_cgraph_basilys passcount=%d", passcount);
+  for (cgr_fun = cgraph_nodes; cgr_fun; cgr_fun = cgr_fun->next)
+    {
+      dbgprintf ("current cgraph cgr_fun %p ", (void *) cgr_fun);
+      if (dump_file)
+	dump_cgraph_node (dump_file, cgr_fun);
+      tr_body = DECL_SAVED_TREE (cgr_fun->decl);
+      dbgprintf ("current cgraph tr_body %p ", (void *) tr_body);
+      if (dump_file)
+	print_generic_stmt (dump_file, tr_body,
+			    TDF_LINENO | TDF_BLOCKS | TDF_DETAILS | TDF_IPA);
+    }
+}
+
+void
+basilys_dbgeprint (void *p)
+{
+  struct debugprint_basilys_st dps = {
+    0, 4, 0
+  };
+  dps.dfil = stderr;
+  basilys_debug_out (&dps, p, 0);
+  putc ('\n', stderr);
+  fflush (stderr);
+}
+
+void
+basilys_dbgbacktrace (int depth)
+{
+  int curdepth = 1, totdepth = 0;
+  struct callframe_basilys_st *fr = 0;
+  fprintf (stderr, "    <{\n");
+  for (fr = basilys_topframe; fr != NULL && curdepth < depth;
+       (fr = fr->prev), (curdepth++))
+    {
+      fprintf (stderr, "frame#%d closure: ", curdepth);
+      basilys_dbgeprint (fr->clos);
+    }
+  for (totdepth = curdepth; fr != NULL; fr = fr->prev);
+  fprintf (stderr, "}> backtraced %d frames of %d\n", curdepth, totdepth);
+  fflush (stderr);
+}
+
+
+void 
+basilys_dbgshortbacktrace(const char* msg, int maxdepth) {
+  int curdepth = 1;
+  struct callframe_basilys_st *fr = 0;
+  if (maxdepth<2) maxdepth=2;
+  fprintf (stderr, "\nSHORT BACKTRACE %s;", msg?msg:"/");
+  for (fr = basilys_topframe; fr != NULL && curdepth < maxdepth;
+       (fr = fr->prev), (curdepth++))
+    {
+      if ((curdepth-1) % 3 == 0) 
+	putc('\n', stderr);
+      fprintf(stderr, "#%d:", curdepth);
+      if (basilys_magic_discr((void*)fr->clos) == OBMAG_CLOSURE) {
+	basilysroutine_ptr_t curout = fr->clos->rout;
+	if (basilys_magic_discr((void*)curout) == OBMAG_ROUTINE)
+	  fprintf(stderr, "<%s> ", curout->routdescr);
+	else
+	  fputs("?norout? ", stderr);
+      } else 
+	fprintf(stderr, "_ ");
+    };
+  if (fr) 
+    fprintf(stderr, "...&%d", maxdepth-curdepth);
+  else
+    fputs(".", stderr);
+  putc('\n', stderr);
+  putc('\n', stderr);
+  fflush(stderr);
+}
+
+/***********************************************************
+ * generate C code for a basilys unit name 
+ ***********************************************************/
+void
+basilys_output_cfile_decl_impl (basilys_ptr_t unitnam,
+				basilys_ptr_t declbuf, basilys_ptr_t implbuf)
+{
+  int unamlen = 0;
+  char *dotcnam = NULL;
+  char *dotcpercentnam = NULL;
+  FILE *cfil = NULL;
+  gcc_assert (basilys_magic_discr (unitnam) == OBMAG_STRING);
+  gcc_assert (basilys_magic_discr (declbuf) == OBMAG_STRBUF);
+  gcc_assert (basilys_magic_discr (implbuf) == OBMAG_STRBUF);
+  /** FIXME : should implement some policy about the location of the
+      generated C file; currently using the pwd */
+  unamlen = strlen (basilys_string_str (unitnam));
+  dotcnam = xcalloc (unamlen + 3, 1);
+  dotcpercentnam = xcalloc (unamlen + 4, 1);
+  strcpy (dotcnam, basilys_string_str (unitnam));
+  strcpy (dotcpercentnam, basilys_string_str (unitnam));
+  strcat (dotcnam, ".c");
+  strcat (dotcpercentnam, ".c%");
+  (void) rename (dotcnam, dotcpercentnam);
+  cfil = fopen (dotcnam, "w");
+  if (!cfil)
+    fatal_error ("failed to open basilys generated file %s - %m", dotcnam);
+  fprintf (cfil,
+	   "/* GCC BASILYS GENERATED FILE %s - DO NOT EDIT */\n", dotcnam);
+  fprintf (cfil, "#include \"run-basilys.h\"\n");
+  fprintf (cfil, "\n/**** %s declarations ****/\n",
+	   basilys_string_str (unitnam));
+  basilys_putstrbuf (cfil, declbuf);
+  putc ('\n', cfil);
+  fflush (cfil);
+  fprintf (cfil, "\n/**** %s implementations ****/\n",
+	   basilys_string_str (unitnam));
+  basilys_putstrbuf (cfil, implbuf);
+  putc ('\n', cfil);
+  fflush (cfil);
+  fprintf (cfil, "\n/**** end of %s ****/\n", basilys_string_str (unitnam));
+  fclose (cfil);
+  free (dotcnam);
+  free (dotcpercentnam);
+}
+
+/* this function decides if Basile's analysis is done. Currently we
+   check for -fbasilys flag; but we should also check for
+   -fwhole-program flag */
+static bool
+gate_basilys (void)
+{
+#if HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL
+  /*@@@ we need to check the whole program flag @@@ */
+  if (!flag_basilys)
+    return 0;
+  if (!flag_whole_program && flag_basilys)
+    {
+      static int warnedonce;
+      if (!warnedonce)
+	{
+	  warnedonce = 1;
+	  warning (OPT_Wall, "-fbasilys flag passed without -fwhole-program");
+	};
+    }
+  return flag_basilys;
+#else /* no HAVE_PARMAPOLY or no HAVE_LIBTOOLDYNL */
+#warning  no HAVE_PARMAPOLY or no HAVE_LIBTOOLDYNL
+  if (flag_basilys)
+    fatal_error ("-fbasilys flag specified, \
+but GCC configured without Parma Polyhedra Library or LibTool Dynamic Loader");
+  return 0;
+#endif
+}
+
+void
+basilys_assert_failed (const char *msg, const char *filnam,
+		       int lineno, const char *fun)
+{
+  static char msgbuf[500];
+  if (basilys_dbgcounter>0)
+    snprintf(msgbuf, sizeof(msgbuf)-1, "%s:%d: BASILYS ASSERT #!%ld: %s {%s}", 
+	     basename (filnam), lineno, basilys_dbgcounter, fun, msg);
+  else
+    snprintf(msgbuf, sizeof(msgbuf)-1, "%s:%d: BASILYS ASSERT: %s {%s}", 
+	     basename (filnam), lineno, fun, msg);
+  basilys_dbgshortbacktrace(msgbuf, 100);
+  fatal_error ("%s:%d: BASILYS ASSERT FAILED <%s> : %s\n",
+	       basename (filnam), lineno, fun, msg);
+}
+
+
+/* this function does the bulk of the work; return additional TODOs to
+   the pass machinery */
+static unsigned int
+execute_basilys (void)
+{
+  static int passcount;
+  passcount++;
+  fprintf (stderr, "\nbasilys.c:%d: start pass %d\n", __LINE__, passcount);
+  dbgprintf ("start of execute_basilys pass %d", passcount);
+  dump_cgraph_basilys (passcount);
+  dbgprintf ("end of execute_basilys pass %d\n", passcount);
+  fprintf (stderr, "basilys.c:%d: end pass %d\n\n", __LINE__, passcount);
+  return 0;
+}
+
+struct tree_opt_pass pass_basilys = {
+  "basilys",			/* name */
+  gate_basilys,			/* gate */
+  execute_basilys,		/* execute */
+  NULL,				/* sub */
+  NULL,				/* next */
+  0,				/* static_pass_number */
+  TV_BASILE_ANALYSIS,		/* tv_id */
+  PROP_cfg | PROP_ssa,		/* properties_required */
+  0,				/* properties_provided */
+  0,				/* properties_destroyed */
+  0,				/* todo_flags_start */
+  0,				/* todo_flags_finish */
+  0				/* letter */
+};
+
+#include "gt-basilys.h"
+/* eof basilys.c */
diff --git a/gcc/basilys.h b/gcc/basilys.h
new file mode 100644
index 00000000000..90d098dad91
--- /dev/null
+++ b/gcc/basilys.h
@@ -0,0 +1,2096 @@
+/* Basile's static analysis (should have a better name) header basilys.h
+   Copyright (C)  2008 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GCC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.   If not see
+<http://www.gnu.org/licenses/>.    */
+
+#ifndef BASILYS_INCLUDED_
+#define BASILYS_INCLUDED_
+
+/* use -fdump-ipa-basilys */
+
+#define dbgprintf_raw(Fmt,...) do{if (dump_file) \
+      {fprintf(dump_file, Fmt, ##__VA_ARGS__); fflush(dump_file);}}while(0)
+#define dbgprintf(Fmt,...) dbgprintf_raw("@%s:%d: " Fmt "\n", \
+ basename(__FILE__), __LINE__, ##__VA_ARGS__)
+
+extern long basilys_dbgcounter;
+
+#define debugeprintf_raw(Fmt,...) do{if (flag_basilys_debug) \
+      {fprintf(stderr, Fmt, ##__VA_ARGS__); fflush(stderr);}}while(0)
+#define debugeprintf(Fmt,...) debugeprintf_raw("!@%s:%d: " Fmt "\n", \
+      basename(__FILE__), __LINE__, ##__VA_ARGS__)
+#define debugeprintvalue(Msg,Val) do{if (flag_basilys_debug){	\
+      void* __val = (Val);					\
+      fprintf(stderr,"!@%s:%d: %s @%p= ",			\
+              basename(__FILE__), __LINE__, (Msg), __val);	\
+      basilys_dbgeprint(__val); }} while(0)
+#define debugebacktrace(Msg,Depth)  do{if (flag_basilys_debug){	\
+      void* __val = (Val);					\
+      fprintf(stderr,"!@%s:%d: %s **backtrace** ",		\
+              basename(__FILE__), __LINE__, (Msg));	\
+      basilys_dbgbacktrace((Depth)); }} while(0)
+/* the maximal debug depth - should be a parameter */
+#define BASILYSDBG_MAXDEPTH 7
+
+/* unspecified flexible dimension in structure */
+#if defined(__STDC__) &&  __STDC__VERSION >= 199901L
+#define FLEXIBLE_DIM		/*flexible */
+#define HAVE_FLEXIBLE_DIM 1
+#else
+#define  FLEXIBLE_DIM /*flexibly*/1
+#define HAVE_FLEXIBLE_DIM 0
+#endif
+
+/* array of (at least 100, increasing order but non consecutive)
+   primes, zero terminated. Each prime is at least 1/8-th bigger than
+   previous */
+extern const long basilys_primtab[256];
+
+
+/* naming convention: all struct basilys*_st are inside the
+   basilys_un */
+
+typedef union basilys_un *basilys_ptr_t;
+typedef struct basilysobject_st *basilysobject_ptr_t;
+typedef struct basilysmapobjects_st *basilysmapobjects_ptr_t;
+typedef struct basilysclosure_st *basilysclosure_ptr_t;
+typedef struct basilysroutine_st *basilysroutine_ptr_t;
+typedef struct basilysmultiple_st *basilysmultiple_ptr_t;
+typedef struct basilysbox_st *basilysbox_ptr_t;
+typedef struct basilyspair_st *basilyspair_ptr_t;
+
+struct debugprint_basilys_st
+{
+  FILE *dfil;
+  int dmaxdepth;
+  int dcount;
+};
+
+void basilys_debug_out (struct debugprint_basilys_st *dp, basilys_ptr_t ptr,
+			int depth);
+void basilys_dbgeprint (void *p);
+void basilys_dbgbacktrace (int depth);
+
+/******************* closures, routines ************************/
+
+union basilysparam_un
+{
+  /* for basilys value pointers, we pass the address of a local, to be
+     compatible with our copying garbage collector */
+  basilys_ptr_t *bp_aptr;	/* letter P */
+#define BPAR_PTR          'P'
+#define BPARSTR_PTR       "P"
+
+  /* for passing a pair-list of rest arguments, we pass likewise the
+     address of a local */
+#define BPAR_RESTPTR      'R'
+#define BPARSTR_RESTPTR   "R"
+  basilys_ptr_t *bp_rptr;	/* letter R */
+
+
+  tree bp_tree;			/* letter t */
+  tree *bp_treeptr;		/* for extra results */
+#define BPAR_TREE         't'
+#define BPARSTR_TREE      "t"
+
+  long bp_long;			/* letter l */
+  long *bp_longptr;		/* for results */
+#define BPAR_LONG         'l'
+#define BPARSTR_LONG      "l"
+
+  edge bp_edge;			/* letter e */
+  edge *bp_edgeptr;		/* for results */
+#define BPAR_EDGE         'e'
+#define BPARSTR_EDGE      "e"
+
+  basic_block bp_bb;		/* letter b */
+  basic_block *bp_bbptr;	/* for results */
+#define BPAR_BB           'b'
+#define BPARSTR_BB        "b"
+};
+
+/*** the closures contain routines which are called by applying
+     closures; each routine is called with:
+
+     + the called closure
+     + this first pointer argument
+     + a (non null, can be empty) constant string describing the extra arguments
+       (eg "ppt" for two value pointers and one tree)
+     + the array of union basilysparam_un for extra arguments
+     + a (non null, can be empty) constant string describing the extra results
+     + the array of union basilysparam_un for extra results
+
+     and the result of the call is a pointer (the main result)
+
+BTW, on AMD64 or x86_64 processors [a very common host at time of
+writing], http://www.x86-64.org/documentation/abi.pdf the first six
+arguments are passed thru registers; on POWERPC eight arguments are
+passed thru registers
+*/
+
+
+typedef basilys_ptr_t basilysroutfun_t (basilysclosure_ptr_t closp_,
+					basilys_ptr_t firstargp_,
+					const char xargdescr_[],
+					union basilysparam_un *xargtab_,
+					const char xresdescr_[],
+					union basilysparam_un *xrestab_);
+
+basilys_ptr_t basilysgc_apply (basilysclosure_ptr_t clos_p,
+			       basilys_ptr_t firstarg,
+			       const char xargdescr_[],
+			       union basilysparam_un *xargtab_,
+			       const char xresdescr_[],
+			       union basilysparam_un *xrestab_);
+
+/* gnu indent has some trouble with GTY hence */
+/* *INDENT-OFF* */
+
+DEF_VEC_P (basilys_ptr_t);
+DEF_VEC_ALLOC_P (basilys_ptr_t, gc);
+
+
+
+DEF_VEC_P (basilysobject_ptr_t);
+DEF_VEC_ALLOC_P (basilysobject_ptr_t, gc);
+
+
+/* sadly we cannot use these types in GTY-ed structure because
+   gengtype don't follow typedefs but these typedef-s are still
+   useful */
+
+typedef
+VEC (basilysobject_ptr_t, gc)
+  basilys_objectvec_t;
+     
+typedef VEC (basilys_ptr_t, gc) basilys_valvec_t;
+
+enum obmag_en    {
+  OBMAG__NONE = 0,
+  OBMAG_OBJECT = 30000,
+  OBMAG_BOX,
+  OBMAG_MULTIPLE,
+  OBMAG_CLOSURE,
+  OBMAG_ROUTINE,
+  OBMAG_LIST,
+  OBMAG_PAIR,
+  OBMAG_TRIPLE,
+  OBMAG_INT,
+  OBMAG_MIXINT,
+  OBMAG_REAL,
+  OBMAG_STRING,
+  OBMAG_STRBUF,
+  OBMAG_TREE,
+  OBMAG_BASICBLOCK,
+  OBMAG_EDGE,
+  OBMAG_MAPOBJECTS,
+  OBMAG_MAPSTRINGS,
+  OBMAG_MAPTREES,
+  OBMAG_MAPBASICBLOCKS,
+  OBMAG_MAPEDGES,
+  OBMAG_DECAY,
+  OBMAG__SPARE1,
+  OBMAG__SPARE2,
+  OBMAG__SPARE3,
+  OBMAG__SPARE4,
+  OBMAG__SPARE5,
+  OBMAG__SPARE6,
+  OBMAG__SPARE7,
+  OBMAG__SPARE8,
+  OBMAG__SPARE9,
+  OBMAG__SPARE10,
+  OBMAG__SPARE11,
+  OBMAG__SPARE12,
+  OBMAG__SPARE13,
+  OBMAG__SPARE14,
+  OBMAG__SPARE15,
+  OBMAG__SPARE16,
+  OBMAG__SPARE17,
+  OBMAG__SPARE18,
+  OBMAG__SPARE19,
+  OBMAG__SPARE20,
+  OBMAG__SPARE21,
+  OBMAG__SPARE22,
+  OBMAG__SPARE23,
+  OBMAG__SPARE24,
+  OBMAG__SPARE25,
+  OBMAG__SPARE26,
+  OBMAG__SPARE27,
+  OBMAG__SPARE28,
+  OBMAG__SPARE29,
+  OBMAG__SPARE30,
+  OBMAG__SPARE31,
+  OBMAG__SPARE32,
+  OBMAG__SPARE33,
+  OBMAG__SPARE34,
+  OBMAG__SPARE35,
+  OBMAG__SPARE36,
+  OBMAG__SPARE37,
+  OBMAG__SPARE38,
+  OBMAG__SPARE39,
+  OBMAG_SPEC_FILE,
+  OBMAG_SPEC_MPFR,
+  OBMAG_SPECPPL_COEFFICIENT,
+  OBMAG_SPECPPL_LINEAR_EXPRESSION,
+  OBMAG_SPECPPL_CONSTRAINT,
+  OBMAG_SPECPPL_CONSTRAINT_SYSTEM,
+  OBMAG_SPECPPL_GENERATOR,
+  OBMAG_SPECPPL_GENERATOR_SYSTEM,
+  OBMAG__LAST
+};
+
+
+/* maxhash can also be used as a bit mask */
+#define BASILYS_MAXHASH 0x3fffffff
+
+/* maxlen can also be used as a bit mask */
+#define BASILYS_MAXLEN 0x1fffffff
+
+
+/***
+    objects are à la ObjVlisp, single-inheritance with a root class, 
+    the discr of an object is its class
+    each object has its hashcode, its magic (used to discriminate non-object values),
+    its number of slots or instance variables object_arity, and an array of slots called vartab[] 
+
+    objects should be allocated in young region, hence discr should be
+    forwarded in the garbage collector
+
+
+
+*/
+
+/* *INDENT-ON* */
+
+/* when OBMAG_OBJECT -- */
+struct basilysobject_st
+GTY (())
+{
+  /* for objects, the discriminant is their class */
+  basilysobject_ptr_t obj_class;
+  unsigned obj_hash;		/* hash code of the object */
+  unsigned short obj_num;
+/* discriminate the basilys_un containing it as discr */
+#define object_magic obj_num
+  unsigned short obj_len;
+  basilys_ptr_t *GTY ((length ("%h.obj_len"))) obj_vartab;
+  /* the following field is usually the value of obj_vartab (for
+     objects in the young zone), to allocate the object and its fields
+     at once; hence its GTY-ed length is zero */
+  basilys_ptr_t GTY ((length ("0"))) obj__tabfields[FLEXIBLE_DIM];
+};
+
+#define BASILYS_OBJECT_STRUCT(N) {		\
+  basilysobject_ptr_t obj_class;		\
+  unsigned obj_hash;				\
+  unsigned short obj_num;			\
+  unsigned short obj_len;			\
+  basilys_ptr_t* obj_vartab;			\
+  basilys_ptr_t obj__tabfields[N];		\
+  long _gap; }
+
+
+/* some types, including objects, strbuf, stringmaps, objectmaps, all
+   the other *maps, contain a pointer to a non value; this pointer
+   should be carefully updated in the forwarding step (and checked if
+   young) */
+
+/* forwarded pointers; nobody see them except the basilys copying
+   garbage collector */
+struct basilysforward_st
+GTY (())
+{
+  basilysobject_ptr_t discr;	/* actually always (void*)1 for forwarded */
+  basilys_ptr_t forward;
+};
+
+/* when OBMAG_DECAY  */
+struct basilysdecay_st
+GTY ((mark_hook ("basilys_mark_decay")))
+{
+  basilysobject_ptr_t discr;
+  basilys_ptr_t val;
+  unsigned remain;		/* remaining number of marking */
+};
+
+
+/* when OBMAG_BOX  */
+struct basilysbox_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  basilys_ptr_t val;
+};
+
+/* when OBMAG_MULTIPLE  */
+struct basilysmultiple_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  unsigned nbval;
+  basilys_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
+};
+
+#define BASILYS_MULTIPLE_STRUCT(N) {		\
+  basilysobject_ptr_t discr;			\
+  unsigned nbval;				\
+  basilys_ptr_t tabval[N];			\
+  long _gap; }
+
+/* when OBMAG_CLOSURE */
+struct basilysclosure_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  basilysroutine_ptr_t rout;
+  unsigned nbval;
+  basilys_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
+};
+
+#define BASILYS_CLOSURE_STRUCT(N) {		\
+  basilysobject_ptr_t discr;			\
+  basilysroutine_ptr_t rout;			\
+  unsigned nbval;				\
+  basilys_ptr_t tabval[N];			\
+  long _gap; }
+
+/* when OBMAG_ROUTINE */
+#define BASILYS_ROUTDESCR_LEN 80
+struct basilysroutine_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  char routdescr[BASILYS_ROUTDESCR_LEN];
+  long GTY ((skip)) routaddr[1 + sizeof (basilysroutfun_t *) / sizeof (long)];
+  unsigned nbval;
+  basilys_ptr_t GTY ((length ("%h.nbval"))) tabval[FLEXIBLE_DIM];
+};
+
+#define BASILYS_ROUTINE_STRUCT(N) {				\
+  basilysobject_ptr_t discr;					\
+  char routdescr[BASILYS_ROUTDESCR_LEN];			\
+  long routaddr[1+sizeof(basilysroutfun_t *)/sizeof(long)];	\
+  unsigned nbval;						\
+  basilys_ptr_t tabval[N];					\
+  long _gap; }
+
+
+/* when OBMAG_PAIR */
+struct basilyspair_st
+GTY ((chain_next ("%h.tl")))
+{
+  basilysobject_ptr_t discr;
+  basilys_ptr_t hd;
+  struct basilyspair_st *tl;
+};
+
+/* when OBMAG_TRIPLE */
+struct basilystriple_st
+GTY ((chain_next ("%h.tl")))
+{
+  basilysobject_ptr_t discr;
+  basilys_ptr_t hd;
+  basilys_ptr_t mi;
+  struct basilystriple_st *tl;
+};
+
+/* when OBMAG_LIST   */
+struct basilyslist_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  struct basilyspair_st *first;
+  struct basilyspair_st *last;
+};
+
+
+
+
+
+/* when OBMAG_INT -  */
+struct basilysint_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  long val;
+};
+
+/* when OBMAG_MIXINT -  */
+struct basilysmixint_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  basilys_ptr_t ptrval;
+  long intval;
+};
+
+
+
+/* when OBMAG_REAL   */
+struct basilysreal_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  REAL_VALUE_TYPE val;
+};
+
+
+/* a union of special pointers which have to be explicitly deleted */
+union special_basilys_un
+{
+  /* all the pointers here have to be pointers to struct or to void,
+     because the generated gtype-desc.c don't include all the files
+     which define mpfr_ptr ppl_Coefficient_t etc... */
+  /* generic pointer */ void *sp_pointer;
+  /* stdio file */ FILE *sp_file;
+  /*mpfr_ptr= */ void *sp_mpfr;
+  /* malloced pointer to mpfr_t */
+  /*ppl_Coefficient_t= */ struct ppl_Coefficient_tag *sp_coefficient;
+  /*ppl_Linear_Expression_t= */ struct ppl_Linear_Expression_tag
+   *sp_linear_expression;
+  /*ppl_Constraint_t= */ struct ppl_Constraint_tag *sp_constraint;
+  /*ppl_Constraint_System_t= */ struct ppl_Constraint_System_tag
+   *sp_constraint_system;
+  /*ppl_Generator_t= */ struct ppl_Generator_tag *sp_generator;
+  /*ppl_Generator_System_t= */ struct ppl_Generator_System_tag
+   *sp_generator_system;
+};
+
+/* PPL special have to be explicitly deleted; hence we need a hook
+   to mark them, an inside mark, and to maintain lists of existing
+   such PPL special boxes -which we scan to delete the unmarked
+   ones */
+/* when OBMAG_SPEC* eg OBMAG_SPEC_MPFR, OBMAG_SPECPPL_COEFFICIENT; etc.
+    */
+struct basilysspecial_st
+GTY ((mark_hook ("basilys_mark_special")))
+{
+  basilysobject_ptr_t discr;
+  int mark;
+  struct basilysspecial_st *GTY ((skip)) nextspec;
+  union special_basilys_un GTY ((skip)) val;
+};
+
+static inline void
+basilys_mark_special (struct basilysspecial_st *p)
+{
+  p->mark = 1;
+}
+
+static inline void
+basilys_mark_decay (struct basilysdecay_st *p)
+{
+  /* this is tricky since it actually changes the marked data; however,
+     changing pointers to NULL is ok! */
+  if (p->remain <= 0)
+    p->val = NULL;
+  else
+    p->remain--;
+}
+
+/* when OBMAG_STRING -  */
+struct basilysstring_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  char val[FLEXIBLE_DIM];	/* null terminated */
+};
+
+#define BASILYS_STRING_STRUCT(N) {		\
+  basilysobject_ptr_t discr;			\
+  char val[(N)+1];	/* null terminated */	\
+  long _gap; }
+
+/* when OBMAG_STRBUF -   */
+struct basilysstrbuf_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  char *GTY ((length ("1+basilys_primtab[%h.buflenix]"))) bufzn;
+  unsigned char buflenix;	/* allocated length index of
+				   buffer */
+  unsigned bufstart;
+  unsigned bufend;		/* start & end useful positions */
+  /* the following field is usually the value of buf (for
+     objects in the young zone), to allocate the object and its fields
+     at once; hence its GTY-ed length is zero */
+  char GTY ((length ("0"))) buf_space[FLEXIBLE_DIM];
+};
+
+/* when OBMAG_TREE  */
+struct basilystree_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  tree val;
+};
+
+/* when OBMAG_BASICBLOCK   */
+struct basilysbasicblock_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  basic_block val;
+};
+
+/* when OBMAG_EDGE   */
+struct basilysedge_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  edge val;
+};
+
+
+
+
+/*** hashed maps of objects to basilys ***/
+struct entryobjectsbasilys_st
+GTY (())
+{
+  basilysobject_ptr_t e_at;
+  basilys_ptr_t e_va;
+};
+
+/* when OBMAG_MAPOBJECTS */
+struct basilysmapobjects_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entryobjectsbasilys_st *GTY ((length ("basilys_primtab[%h.lenix]")))
+    entab;
+  /* the following field is usually the value of entab (for
+     objects in the young zone), to allocate the object and its fields
+     at once; hence its GTY-ed length is zero */
+  struct entryobjectsbasilys_st GTY ((length ("0"))) map_space[FLEXIBLE_DIM];
+};
+
+/*** hashed maps of trees to basilys ***/
+struct entrytreesbasilys_st
+GTY (())
+{
+  tree e_at;
+  basilys_ptr_t e_va;
+};
+
+/* when OBMAG_MAPTREES */
+struct basilysmaptrees_st
+GTY (())
+{
+  /* change basilysmappointers_st when changing this structure */
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entrytreesbasilys_st *GTY ((length ("basilys_primtab[%h.lenix]")))
+    entab;
+};
+
+/*** hashed maps of strings to basilys ***/
+struct entrystringsbasilys_st
+GTY (())
+{
+  char *GTY (()) e_at;
+  basilys_ptr_t e_va;
+};
+
+/* when OBMAG_MAPSTRINGS */
+struct basilysmapstrings_st
+GTY (())
+{
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entrystringsbasilys_st *GTY ((length ("basilys_primtab[%h.lenix]")))
+    entab;
+};
+
+
+/*** hashed maps of basicblocks to basilys ***/
+
+struct entrybasicblocksbasilys_st
+GTY (())
+{
+  basic_block e_at;
+  basilys_ptr_t e_va;
+};
+
+/* when OBMAG_MAPBASICBLOCKS */
+struct basilysmapbasicblocks_st
+GTY (())
+{
+  /* change basilysmappointers_st when changing this structure */
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entrybasicblocksbasilys_st
+    *GTY ((length ("basilys_primtab[%h.lenix]"))) entab;
+};
+
+/*** hashed maps of edges to basilys ***/
+struct entryedgesbasilys_st
+GTY (())
+{
+  edge e_at;
+  basilys_ptr_t e_va;
+};
+
+/* when OBMAG_MAPEDGES */
+struct basilysmapedges_st
+GTY (())
+{
+  /* change basilysmappointers_st when changing this structure */
+  basilysobject_ptr_t discr;
+  unsigned count;
+  unsigned char lenix;
+  struct entryedgesbasilys_st *GTY ((length ("basilys_primtab[%h.lenix]")))
+    entab;
+};
+
+
+/**** our union for everything ***/
+/* never use an array of basilys_un, only array of pointers basilys_ptr_t */
+typedef union basilys_un
+GTY ((desc ("%0.u_discr->object_magic")))
+{
+  basilysobject_ptr_t GTY ((skip)) u_discr;
+  struct basilysforward_st GTY ((skip)) u_forward;
+  struct basilysobject_st GTY ((tag ("OBMAG_OBJECT"))) u_object;
+  struct basilysbox_st GTY ((tag ("OBMAG_BOX"))) u_box;
+  struct basilysdecay_st GTY ((tag ("OBMAG_DECAY"))) u_decay;
+  struct basilysmultiple_st GTY ((tag ("OBMAG_MULTIPLE"))) u_multiple;
+  struct basilysclosure_st GTY ((tag ("OBMAG_CLOSURE"))) u_closure;
+  struct basilysroutine_st GTY ((tag ("OBMAG_ROUTINE"))) u_routine;
+  struct basilyslist_st GTY ((tag ("OBMAG_LIST"))) u_list;
+  struct basilysint_st GTY ((tag ("OBMAG_INT"))) u_int;
+  struct basilysmixint_st GTY ((tag ("OBMAG_MIXINT"))) u_mixint;
+  struct basilysreal_st GTY ((tag ("OBMAG_REAL"))) u_real;
+  struct basilyspair_st GTY ((tag ("OBMAG_PAIR"))) u_pair;
+  struct basilystriple_st GTY ((tag ("OBMAG_TRIPLE"))) u_triple;
+  struct basilysspecial_st
+    GTY ((tag ("OBMAG_SPEC_FILE"),
+	  tag ("OBMAG_SPEC_MPFR"),
+	  tag ("OBMAG_SPECPPL_COEFFICIENT"),
+	  tag ("OBMAG_SPECPPL_LINEAR_EXPRESSION"),
+	  tag ("OBMAG_SPECPPL_CONSTRAINT"),
+	  tag ("OBMAG_SPECPPL_CONSTRAINT_SYSTEM"),
+	  tag ("OBMAG_SPECPPL_GENERATOR"),
+	  tag ("OBMAG_SPECPPL_GENERATOR_SYSTEM"))) u_special;
+  struct basilysstring_st GTY ((tag ("OBMAG_STRING"))) u_string;
+  struct basilysstrbuf_st GTY ((tag ("OBMAG_STRBUF"))) u_strbuf;
+  struct basilystree_st GTY ((tag ("OBMAG_TREE"))) u_tree;
+  struct basilysbasicblock_st GTY ((tag ("OBMAG_BASICBLOCK"))) u_basicblock;
+  struct basilysedge_st GTY ((tag ("OBMAG_EDGE"))) u_edge;
+  struct basilysmapobjects_st GTY ((tag ("OBMAG_MAPOBJECTS"))) u_mapobjects;
+  struct basilysmapstrings_st GTY ((tag ("OBMAG_MAPSTRINGS"))) u_mapstrings;
+  struct basilysmaptrees_st GTY ((tag ("OBMAG_MAPTREES"))) u_maptrees;
+  struct basilysmapbasicblocks_st GTY ((tag ("OBMAG_MAPBASICBLOCKS")))
+    u_mapbasicblocks;
+  struct basilysmapedges_st GTY ((tag ("OBMAG_MAPEDGES"))) u_mapedges;
+} basilys_un_t;
+
+/* return the magic of the discriminant or 0 */
+static inline int
+basilys_magic_discr (basilys_ptr_t p)
+{
+  if (!p || !p->u_discr)
+    return 0;
+  return p->u_discr->object_magic;
+}
+
+/* return the discriminant or class itself */
+static inline basilysobject_ptr_t
+basilys_discr (basilys_ptr_t p)
+{
+  if (!p)
+    return NULL;
+  return p->u_discr;
+}
+
+/* return the nth of a multiple (starting from 0) */
+static inline basilys_ptr_t
+basilys_multiple_nth (basilysmultiple_ptr_t mul, int n)
+{
+  if (!mul || mul->discr->object_magic != OBMAG_MULTIPLE)
+    return NULL;
+  if (n >= 0 && n < (int) mul->nbval)
+    return mul->tabval[n];
+  else if (n < 0 && n + (int) mul->nbval >= 0)
+    return mul->tabval[n + mul->nbval];
+  return NULL;
+}
+
+/* set the nth of a multiple (but beware of circularities!) */
+void basilysgc_multiple_put_nth (basilysmultiple_ptr_t mul, int n,
+				 basilys_ptr_t val);
+
+/* return the length of a multiple */
+static inline int
+basilys_multiple_length (basilysmultiple_ptr_t mul)
+{
+  if (!mul || mul->discr->object_magic != OBMAG_MULTIPLE)
+    return 0;
+  return mul->nbval;
+}
+
+/* allocate a new box of given DISCR & content VAL */
+basilys_ptr_t basilysgc_new_box (basilysobject_ptr_t discr_p,
+				 basilys_ptr_t val_p);
+
+/* return the content of a box */
+static inline basilys_ptr_t
+basilys_box_content (basilysbox_ptr_t box)
+{
+  if (!box || box->discr->object_magic != OBMAG_BOX)
+    return NULL;
+  return box->val;
+}
+
+void basilysgc_box_put (basilys_ptr_t box, basilys_ptr_t val);
+
+
+void *basilysgc_raw_new_mappointers (basilysobject_ptr_t discr_p,
+				     unsigned len);
+
+static inline basilys_ptr_t
+basilysgc_new_maptrees (basilysobject_ptr_t discr, unsigned len)
+{
+  if (basilys_magic_discr ((void *) discr) != OBMAG_OBJECT)
+    return NULL;
+  if (discr->object_magic != OBMAG_MAPTREES)
+    return NULL;
+  return basilysgc_raw_new_mappointers (discr, len);
+}
+
+static inline basilys_ptr_t
+basilysgc_new_mapedges (basilysobject_ptr_t discr, unsigned len)
+{
+  if (basilys_magic_discr ((void *) discr) != OBMAG_OBJECT)
+    return NULL;
+  if (discr->object_magic != OBMAG_MAPEDGES)
+    return NULL;
+  return basilysgc_raw_new_mappointers (discr, len);
+}
+
+static inline basilys_ptr_t
+basilysgc_new_mapbasicblocks (basilysobject_ptr_t discr, unsigned len)
+{
+  if (basilys_magic_discr ((void *) discr) != OBMAG_OBJECT)
+    return NULL;
+  if (discr->object_magic != OBMAG_MAPBASICBLOCKS)
+    return NULL;
+  return basilysgc_raw_new_mappointers (discr, len);
+}
+void
+basilysgc_raw_put_mappointers (void *mappointer_p,
+			       const void *attr, basilys_ptr_t valu_p);
+
+static inline void
+basilysgc_put_maptrees (struct basilysmaptrees_st *map_p,
+			tree attr, basilys_ptr_t valu_p)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPTREES
+      || !attr || !valu_p)
+    return;
+  basilysgc_raw_put_mappointers (map_p, attr, valu_p);
+}
+
+static inline void
+basilysgc_put_mapedges (struct basilysmapedges_st *map_p,
+			edge attr, basilys_ptr_t valu_p)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPEDGES
+      || !attr || !valu_p)
+    return;
+  basilysgc_raw_put_mappointers (map_p, attr, valu_p);
+}
+
+static inline void
+basilysgc_put_mapbasicblocks (struct basilysmapbasicblocks_st *map_p,
+			      basic_block attr, basilys_ptr_t valu_p)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPBASICBLOCKS
+      || !attr || !valu_p)
+    return;
+  basilysgc_raw_put_mappointers (map_p, attr, valu_p);
+}
+
+
+basilys_ptr_t
+basilys_raw_get_mappointers (void *mappointer_p, const void *attr);
+
+static inline basilys_ptr_t
+basilys_get_maptrees (basilys_ptr_t map_p, tree attr)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPTREES || !attr)
+    return NULL;
+  return basilys_raw_get_mappointers (map_p, attr);
+}
+
+static inline basilys_ptr_t
+basilys_get_mapedges (basilys_ptr_t map_p, edge attr)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPEDGES || !attr)
+    return NULL;
+  return basilys_raw_get_mappointers (map_p, attr);
+}
+
+static inline basilys_ptr_t
+basilys_get_mapbasicblocks (basilys_ptr_t map_p, basic_block attr)
+{
+  if (basilys_magic_discr ((void *) map_p) != OBMAG_MAPBASICBLOCKS || !attr)
+    return NULL;
+  return basilys_raw_get_mappointers (map_p, attr);
+}
+
+basilys_ptr_t
+basilysgc_raw_remove_mappointers (void *mappointer_p, const void *attr);
+
+static inline basilys_ptr_t
+basilysgc_remove_maptrees (struct basilysmaptrees_st *map, tree attr)
+{
+  if (basilys_magic_discr ((void *) map) != OBMAG_MAPTREES || !attr)
+    return NULL;
+  return basilysgc_raw_remove_mappointers (map, attr);
+}
+
+static inline basilys_ptr_t
+basilysgc_remove_mapedges (struct basilysmaptrees_st *map, edge attr)
+{
+  if (basilys_magic_discr ((void *) map) != OBMAG_MAPEDGES || !attr)
+    return NULL;
+  return basilysgc_raw_remove_mappointers (map, attr);
+}
+
+static inline basilys_ptr_t
+basilysgc_remove_mapbasicblocks (struct basilysmapbasicblocks_st *map,
+				 basic_block attr)
+{
+  if (basilys_magic_discr ((void *) map) != OBMAG_MAPBASICBLOCKS || !attr)
+    return NULL;
+  return basilysgc_raw_remove_mappointers (map, attr);
+}
+
+/*************************************************************
+ * young generation copying garbage collector 
+ *
+ * the young generation is managed specifically by an additional
+ * copying garbage collector, which copies basilys_ptr_t data into the
+ * GGC heap from a young region.  This requires that every local
+ * variable is known to our copying basilys GC. For that purpose,
+ * locals are copied (or used) inside a chain of callframe_basilys_st
+ * structures. Since our copying GC change pointers, every allocation
+ * or call may change all the frames. Also stores inside data should
+ * be explicitly managed in a store list
+ *
+ * the young allocation zone is typically of a few megabytes when it
+ * is full, a minor garbage collection occur (and possibly a full GGC
+ * collection afterwards) which changes all the locals
+ *************************************************************/
+
+/* start and end of young allocation zone */
+extern void *basilys_startalz;
+extern void *basilys_endalz;
+/* current allocation pointer aligned */
+extern char *basilys_curalz;
+/* the store vector grows downward */
+extern void **basilys_storalz;
+/* list of specials in the allocation zone */
+extern struct basilysspecial_st *basilys_newspeclist;
+/* list of specials in the heap */
+extern struct basilysspecial_st *basilys_oldspeclist;
+/* kilowords allocated since last full collection */
+extern unsigned long basilys_kilowords_sincefull;
+/* number of full & any basilys garbage collections */
+extern unsigned long basilys_nb_full_garbcoll;
+extern unsigned long basilys_nb_garbcoll;
+
+extern bool basilys_prohibit_garbcoll;
+
+/* extra scanning routine pointer - only for GC experts, and mostly
+   useful to possibly scan bison or yacc semantic value stack */
+extern void (*basilys_extra_scanrout_p) (void);
+
+/* the basilys copying garbage collector routine - moves all locals on the stack! */
+enum
+{ BASILYS_MINOR_OR_FULL = 0, BASILYS_NEED_FULL = 1 };
+void basilys_garbcoll (size_t wanted, bool needfull);
+
+/* the alignment */
+#if defined(__GNUC__) && !defined(__STRICT_ANSI__)
+#define BASILYS_ALIGN (__alignof__(union basilys_un))
+#define BASILYS_LIKELY(P) __builtin_expect((P),1)
+#define BASILYS_UNLIKELY(P) __builtin_expect((P),0)
+#else
+#define BASILYS_ALIGN (2*sizeof(void*))
+#define BASILYS_LIKELY(P) (P)
+#define BASILYS_UNLIKELY(P) (P)
+#endif
+
+static inline bool
+basilys_is_young (const void *p)
+{
+  return (char *) p >= (char *) basilys_startalz
+    && (char *) p < (char *) basilys_endalz;
+}
+
+
+#if ENABLE_CHECKING
+/* to ease debugging we sometimes want to know when some pointer is
+   allocated: set these variables in the debugger */
+static void* tracedptr1;
+static void* tracedptr2;
+#endif
+
+/* the allocator routine allocates a zone of BASESZ with extra GAP */
+static inline void *
+basilysgc_allocate (size_t basesz, size_t gap)
+{
+  size_t wanted;
+  void *ptr;
+  if (basesz < sizeof (struct basilysforward_st))
+    basesz = sizeof (struct basilysforward_st);
+  if ((basesz % BASILYS_ALIGN) != 0)
+    basesz += (BASILYS_ALIGN - (basesz % BASILYS_ALIGN));
+  if ((gap % BASILYS_ALIGN) != 0)
+    gap += (BASILYS_ALIGN - (gap % BASILYS_ALIGN));
+  wanted = basesz + gap;
+  gcc_assert (wanted >= sizeof (struct basilysforward_st));
+  if (BASILYS_UNLIKELY (basilys_curalz + wanted + 2 * BASILYS_ALIGN
+			>= (char *) basilys_storalz))
+    basilys_garbcoll (wanted, BASILYS_MINOR_OR_FULL);
+  ptr = basilys_curalz;
+#if ENABLE_CHECKING
+  if (ptr == tracedptr1)
+    debugeprintf("allocated tracedptr1 %p", ptr);
+  else if (ptr == tracedptr2)
+    debugeprintf("allocated tracedptr2 %p", ptr);
+#endif
+  basilys_curalz += wanted;
+  return ptr;
+}
+
+
+/* we maintain a small cache hasharray of touched values - the touched
+   cache size should be a small prime */
+#define BASILYS_TOUCHED_CACHE_SIZE 17
+extern void *basilys_touched_cache[BASILYS_TOUCHED_CACHE_SIZE];
+/* the touching routine should be called on every basilys value which
+   has been touched (by mutating one of its internal pointers) - it
+   may add the touched value to the store "array" and may trigger our
+   basilys copying garbage collector */
+static inline void
+basilysgc_touch (void *touchedptr)
+{
+  /* we know that this may loose -eg on some 64bits hosts- some
+     highend bits of the pointer but we don't care, since the 32
+     lowest bits are enough (as hash); we need a double cast to avoid
+     a warning */
+  unsigned pad = (unsigned) (HOST_WIDE_INT) touchedptr;
+  if ((char *) touchedptr >= (char *) basilys_startalz
+      && (char *) touchedptr <= (char *) basilys_endalz)
+    return;
+  pad = pad % (unsigned) BASILYS_TOUCHED_CACHE_SIZE;
+  if (basilys_touched_cache[pad] == touchedptr)
+    return;
+  *basilys_storalz = touchedptr;
+  basilys_storalz--;
+  basilys_touched_cache[pad] = touchedptr;
+  if (BASILYS_UNLIKELY
+      ((char *) ((void **) basilys_storalz - 3) <= (char *) basilys_curalz))
+    basilys_garbcoll (1024 * sizeof (void *) +
+		      ((char *) basilys_endalz - (char *) basilys_storalz),
+		      BASILYS_MINOR_OR_FULL);
+}
+
+/* we can avoid the hassle of adding a touched pointer to the store
+   list if we know that the newly added pointer inside does not point
+   into the new allocation zone; TOUCHEDPTR is the mutated value and
+   DSTPTR is the newly added pointer insided */
+static inline void
+basilysgc_touch_dest (void *touchedptr, void *destptr)
+{
+  /* if we add an old pointer we don't care */
+  if (!basilys_is_young(destptr))
+    return;
+  basilysgc_touch (touchedptr);
+}
+
+
+
+
+
+
+/* low level map routines */
+
+
+/***
+ * allocation routines that may trigger a garbage collection 
+ * (their name starts with basilysgc)
+ ***/
+
+/* allocate a boxed long integer (or null if bad DISCR) fillen with NUM */
+basilys_ptr_t basilysgc_new_int (basilysobject_ptr_t discr, long num);
+
+static inline long
+basilys_get_int (basilys_ptr_t v)
+{
+  switch (basilys_magic_discr (v))
+    {
+    case OBMAG_INT:
+      return ((struct basilysint_st *) (v))->val;
+    case OBMAG_MIXINT:
+      return ((struct basilysmixint_st *) (v))->intval;
+    case OBMAG_OBJECT:
+      return ((basilysobject_ptr_t) (v))->obj_num;
+    default:
+      return 0;
+    }
+}
+
+static inline bool
+basilys_put_int (basilys_ptr_t v, long x)
+{
+  switch (basilys_magic_discr (v))
+    {
+    case OBMAG_INT:
+      ((struct basilysint_st *) (v))->val = x;
+      return TRUE;
+    case OBMAG_MIXINT:
+      ((struct basilysmixint_st *) (v))->intval = x;
+      return TRUE;
+    case OBMAG_OBJECT:
+      if (((basilysobject_ptr_t) (v))->obj_num != 0)
+	return FALSE;
+      ((basilysobject_ptr_t) (v))->obj_num = (unsigned short) x;
+      return TRUE;
+    default:
+      return FALSE;
+    }
+}
+
+
+static inline long
+basilys_obj_hash (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_OBJECT)
+    return ((basilysobject_ptr_t) (v))->obj_hash;
+  return 0;
+}
+
+
+static inline long
+basilys_obj_len (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_OBJECT)
+    return ((basilysobject_ptr_t) (v))->obj_len;
+  return 0;
+}
+
+static inline long
+basilys_obj_num (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_OBJECT)
+    return ((basilysobject_ptr_t) (v))->obj_num;
+  return 0;
+}
+
+/* safe integer div & mod */
+static inline long
+basilys_idiv (long i, long j)
+{
+  return (j != 0) ? (i / j) : 0;
+}
+static inline long
+basilys_imod (long i, long j)
+{
+  return (j != 0) ? (i % j) : 0;
+}
+
+
+
+/* allocate a boxed mixed integer & value) */
+basilys_ptr_t
+basilysgc_new_mixint (basilysobject_ptr_t discr_p, basilys_ptr_t val_p,
+		      long num);
+
+static inline basilys_ptr_t
+basilys_val_mixint (basilys_ptr_t mix)
+{
+  struct basilysmixint_st *smix = (void *) mix;
+  if (basilys_magic_discr (mix) == OBMAG_MIXINT)
+    return smix->ptrval;
+  return NULL;
+}
+
+static inline long
+basilys_num_mixint (basilys_ptr_t mix)
+{
+  struct basilysmixint_st *smix = (void *) mix;
+  if (basilys_magic_discr (mix) == OBMAG_MIXINT)
+    return smix->intval;
+  return 0;
+}
+
+
+/* get (safely) the nth (counting from 0) field of an object */
+static inline basilys_ptr_t
+basilys_field_object (basilys_ptr_t ob, unsigned off)
+{
+  if (basilys_magic_discr (ob) == OBMAG_OBJECT)
+    {
+      basilysobject_ptr_t pob = (void *) ob;
+      if (off < pob->obj_len)
+	return pob->obj_vartab[off];
+    };
+  return NULL;
+}
+
+/* get (safely) the length of an object */
+static inline int
+basilys_object_length (basilys_ptr_t ob)
+{
+  if (basilys_magic_discr (ob) == OBMAG_OBJECT)
+    {
+      basilysobject_ptr_t pob = (void *) ob;
+      return pob->obj_len;
+    }
+  return 0;
+}
+
+/* allocate a new string (or null if bad DISCR or null STR) initialized from
+   _static_ (non gc-ed) memory STR  */
+basilys_ptr_t basilysgc_new_string (basilysobject_ptr_t discr,
+				    const char *str);
+
+/* allocate a new string (or null if bad DISCR or null STR) initialized from
+   a memory STR which is temporarily duplicated (so can be in gc-ed) */
+basilys_ptr_t basilysgc_new_stringdup (basilysobject_ptr_t discr,
+				       const char *str);
+
+/* get the naked nasename of a path, ie from "/foo/bar.gyz" return "bar"; argument is duplicated */
+basilys_ptr_t basilysgc_new_string_nakedbasename (basilysobject_ptr_t discr,
+						  const char *str);
+
+static inline const char *
+basilys_string_str (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_STRING)
+    return ((struct basilysstring_st *) v)->val;
+  return 0;
+}
+
+static inline int
+basilys_string_length (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_STRING)
+    return strlen(((struct basilysstring_st *) v)->val);
+  return 0;
+}
+
+static inline bool
+basilys_string_same (basilys_ptr_t v1, basilys_ptr_t v2)
+{
+  if (basilys_magic_discr (v1) == OBMAG_STRING
+      && basilys_magic_discr (v2) == OBMAG_STRING)
+    {
+      return 0 == strcmp (((struct basilysstring_st *) v1)->val,
+			  ((struct basilysstring_st *) v2)->val);
+    }
+  return 0;
+}
+
+static inline const char *
+basilys_strbuf_str (basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_STRBUF)
+    {
+      struct basilysstrbuf_st *sb = (void *) v;
+      if (sb->bufend >= sb->bufstart)
+	return sb->bufzn + sb->bufstart;
+    }
+  return 0;
+}
+
+static inline int
+basilys_strbuf_usedlength(basilys_ptr_t v)
+{
+  if (basilys_magic_discr (v) == OBMAG_STRBUF)
+    {
+      struct basilysstrbuf_st *sb = (void *) v;
+      if (sb->bufend >= sb->bufstart)
+	return sb->bufend - sb->bufstart;
+    }
+  return 0;
+}
+
+
+/* allocate a pair of given head and tail */
+basilys_ptr_t basilysgc_new_pair (basilysobject_ptr_t discr,
+				  void *head, void *tail);
+
+/* change the head of a pair */
+void basilysgc_pair_set_head(basilys_ptr_t pair, void* head);
+
+/* allocate a new multiple of given DISCR & length LEN */
+basilys_ptr_t basilysgc_new_multiple (basilysobject_ptr_t discr_p,
+				      unsigned len);
+
+/* allocate a multiple of arity 1 */
+basilys_ptr_t basilysgc_new_mult1 (basilysobject_ptr_t discr_p,
+				   basilys_ptr_t v0_p);
+/* allocate a multiple of arity 2 */
+basilys_ptr_t basilysgc_new_mult2 (basilysobject_ptr_t discr_p,
+				   basilys_ptr_t v0_p, basilys_ptr_t v1_p);
+/* allocate a multiple of arity 3 */
+basilys_ptr_t basilysgc_new_mult3 (basilysobject_ptr_t discr_p,
+				   basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+				   basilys_ptr_t v2_p);
+/* allocate a multiple of arity 4 */
+basilys_ptr_t basilysgc_new_mult4 (basilysobject_ptr_t discr_p,
+				   basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+				   basilys_ptr_t v2_p, basilys_ptr_t v3_p);
+/* allocate a multiple of arity 5 */
+basilys_ptr_t basilysgc_new_mult5 (basilysobject_ptr_t discr_p,
+				   basilys_ptr_t v0_p, basilys_ptr_t v1_p,
+				   basilys_ptr_t v2_p, basilys_ptr_t v3_p,
+				   basilys_ptr_t v4_p);
+
+/* allocate a new (empty) list */
+basilys_ptr_t basilysgc_new_list (basilysobject_ptr_t discr_p);
+/* append to the tail of a list */
+void basilysgc_append_list (basilys_ptr_t list_p, basilys_ptr_t val_p);
+/* prepend to the head of a list */
+void basilysgc_prepend_list (basilys_ptr_t list_p, basilys_ptr_t val_p);
+/* pop from head of list (and remove) */
+basilys_ptr_t basilysgc_popfirst_list (basilys_ptr_t list_p);
+
+/* return the length of a list or -1 iff non list */
+int basilys_list_length (basilys_ptr_t list_p);
+
+/* allocate e new empty mapobjects */
+basilys_ptr_t basilysgc_new_mapobjects (basilysobject_ptr_t discr_p,
+					unsigned len);
+
+/* put into a mapobjects */
+void basilysgc_put_mapobjects (basilysmapobjects_ptr_t mapobject_p,
+			       basilysobject_ptr_t attrobject_p,
+			       basilys_ptr_t valu_p);
+
+/* get from a mapobject */
+basilys_ptr_t basilys_get_mapobjects (basilysmapobjects_ptr_t mapobject_p,
+				      basilysobject_ptr_t attrobject_p);
+
+/* remove from a mapobject (return the removed value) */
+basilys_ptr_t basilysgc_remove_mapobjects (basilysmapobjects_ptr_t
+					   mapobject_p,
+					   basilysobject_ptr_t attrobject_p);
+
+static inline int
+basilys_size_mapobjects (basilysmapobjects_ptr_t mapobject_p)
+{
+  if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS)
+    return 0;
+  return basilys_primtab[mapobject_p->lenix];
+}
+
+static inline unsigned
+basilys_count_mapobjects (basilysmapobjects_ptr_t mapobject_p)
+{
+  if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS)
+    return 0;
+  return mapobject_p->count;
+}
+
+static inline basilysobject_ptr_t
+basilys_nthattr_mapobjects (basilysmapobjects_ptr_t mapobject_p, int ix)
+{
+  basilysobject_ptr_t at = 0;
+  if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS)
+    return 0;
+  if (ix < 0 || ix >= basilys_primtab[mapobject_p->lenix])
+    return 0;
+  at = mapobject_p->entab[ix].e_at;
+  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
+    return 0;
+  return at;
+}
+
+static inline basilys_ptr_t
+basilys_nthval_mapobjects (basilysmapobjects_ptr_t mapobject_p, int ix)
+{
+  basilysobject_ptr_t at = 0;
+  if (!mapobject_p || mapobject_p->discr->obj_num != OBMAG_MAPOBJECTS)
+    return 0;
+  if (ix < 0 || ix >= basilys_primtab[mapobject_p->lenix])
+    return 0;
+  at = mapobject_p->entab[ix].e_at;
+  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
+    return 0;
+  return mapobject_p->entab[ix].e_va;
+}
+
+/* allocate a new empty mapstrings */
+basilys_ptr_t basilysgc_new_mapstrings (basilysobject_ptr_t discr_p,
+					unsigned len);
+
+/* put into a mapstrings, the string is copied so can be in the gc-ed heap */
+void basilysgc_put_mapstrings (struct basilysmapstrings_st *mapstring_p,
+			       const char *str, basilys_ptr_t valu_p);
+
+/* get from a mapstring */
+basilys_ptr_t basilys_get_mapstrings (struct basilysmapstrings_st
+				      *mapstring_p, const char *attr);
+
+
+/* remove from a mapstring (return the removed value) */
+basilys_ptr_t basilysgc_remove_mapstrings (struct basilysmapstrings_st
+					   *mapstring_p, const char *str);
+
+static inline int
+basilys_size_mapstrings (struct basilysmapstrings_st *mapstring_p)
+{
+  if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS)
+    return 0;
+  return basilys_primtab[mapstring_p->lenix];
+}
+
+static inline unsigned
+basilys_count_mapstrings (struct basilysmapstrings_st *mapstring_p)
+{
+  if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS)
+    return 0;
+  return mapstring_p->count;
+}
+
+static inline const char *
+basilys_nthattrraw_mapstrings (struct basilysmapstrings_st *mapstring_p,
+			       int ix)
+{
+  const char *at = 0;
+  if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS)
+    return 0;
+  if (ix < 0 || ix >= basilys_primtab[mapstring_p->lenix])
+    return 0;
+  at = mapstring_p->entab[ix].e_at;
+  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
+    return 0;
+  return at;
+}
+
+static inline basilys_ptr_t
+basilys_nthval_mapstrings (struct basilysmapstrings_st *mapstring_p, int ix)
+{
+  const char *at = 0;
+  if (!mapstring_p || mapstring_p->discr->obj_num != OBMAG_MAPSTRINGS)
+    return 0;
+  if (ix < 0 || ix >= basilys_primtab[mapstring_p->lenix])
+    return 0;
+  at = mapstring_p->entab[ix].e_at;
+  if ((void *) at == (void *) HTAB_DELETED_ENTRY)
+    return 0;
+  return mapstring_p->entab[ix].e_va;
+}
+
+/* allocate a new routine object of given DISCR and of length LEN,
+   with a DESCR-iptive string a a PROC-edure */
+basilysroutine_ptr_t basilysgc_new_routine (basilysobject_ptr_t discr_p,
+					    unsigned len, const char *descr,
+					    basilysroutfun_t * proc);
+
+
+static inline char *
+basilys_routine_descrstr (basilys_ptr_t rout)
+{
+  if (rout && ((basilysroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE)
+    return ((basilysroutine_ptr_t) rout)->routdescr;
+  return (char *) 0;
+}
+
+static inline int
+basilys_routine_size (basilys_ptr_t rout)
+{
+  if (rout && ((basilysroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE)
+    return ((basilysroutine_ptr_t) rout)->nbval;
+  return 0;
+}
+
+static inline basilys_ptr_t
+basilys_routine_nth (basilys_ptr_t rout, int ix)
+{
+  if (rout && ((basilysroutine_ptr_t) rout)->discr->obj_num == OBMAG_ROUTINE)
+    if (ix >= 0 && ix < (int) ((basilysroutine_ptr_t) rout)->nbval)
+      return ((basilysroutine_ptr_t) rout)->tabval[ix];
+  return 0;
+}
+
+/*********/
+/* allocate a new closure of given DISCR with a given ROUT,  and of length LEN
+ */
+basilysclosure_ptr_t basilysgc_new_closure (basilysobject_ptr_t discr_p,
+					    basilysroutine_ptr_t rout_p,
+					    unsigned len);
+
+static inline int
+basilys_closure_size (basilys_ptr_t clo)
+{
+  if (clo && ((basilysclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE)
+    return ((basilysclosure_ptr_t) clo)->nbval;
+  return 0;
+}
+
+static inline basilys_ptr_t
+basilys_closure_routine (basilys_ptr_t clo)
+{
+  if (clo && ((basilysclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE)
+    return (basilys_ptr_t) (((basilysclosure_ptr_t) clo)->rout);
+  return 0;
+}
+
+static inline basilys_ptr_t
+basilys_closure_nth (basilys_ptr_t clo, int ix)
+{
+  if (clo && ((basilysclosure_ptr_t) clo)->discr->obj_num == OBMAG_CLOSURE
+      && ix >= 0 && ix < (int) (((basilysclosure_ptr_t) clo)->nbval))
+    return (basilys_ptr_t) (((basilysclosure_ptr_t) clo)->tabval[ix]);
+  return 0;
+}
+
+
+/***** list and pairs accessors ****/
+/* safe pair head & tail accessors */
+static inline basilys_ptr_t
+basilys_pair_head (basilys_ptr_t pair)
+{
+  if (pair && ((struct basilyspair_st *) pair)->discr->obj_num == OBMAG_PAIR)
+    return ((struct basilyspair_st *) pair)->hd;
+  return 0;
+}
+
+static inline basilys_ptr_t
+basilys_pair_tail (basilys_ptr_t pair)
+{
+  if (pair && ((struct basilyspair_st *) pair)->discr->obj_num == OBMAG_PAIR)
+    return (basilys_ptr_t) (((struct basilyspair_st *) pair)->tl);
+  return 0;
+}
+
+/* compute the length of a pairlist */
+static inline long
+basilys_pair_listlength (basilys_ptr_t pair)
+{
+  long l = 0;
+  while (pair
+	 && ((struct basilyspair_st *) pair)->discr->obj_num == OBMAG_PAIR)
+    {
+      l++;
+      pair = (basilys_ptr_t) (((struct basilyspair_st *) pair)->tl);
+    };
+  return l;
+}
+
+static inline basilys_ptr_t
+basilys_list_first (basilys_ptr_t lis)
+{
+  if (lis && ((struct basilyslist_st *) lis)->discr->obj_num == OBMAG_LIST)
+    return (basilys_ptr_t) (((struct basilyslist_st *) lis)->first);
+  return NULL;
+}
+
+static inline basilys_ptr_t
+basilys_list_last (basilys_ptr_t lis)
+{
+  if (lis && ((struct basilyslist_st *) lis)->discr->obj_num == OBMAG_LIST)
+    return (basilys_ptr_t) (((struct basilyslist_st *) lis)->last);
+  return NULL;
+}
+
+/* allocate a new raw object of given KLASS (unchecked) with LEN slots */
+basilysobject_ptr_t basilysgc_new_raw_object (basilysobject_ptr_t klass_p,
+					      unsigned len);
+
+
+/***** STRBUF ie string buffers *****/
+
+/* allocate a new strbuf of given DISCR with initial content STR */
+struct basilysstrbuf_st *basilysgc_new_strbuf (basilysobject_ptr_t discr_p,
+					       const char *str);
+
+/* add into STRBUF the static string STR (which is not in the basilys heap) */
+void basilysgc_add_strbuf_raw (struct basilysstrbuf_st *strbuf_p,
+			       const char *str);
+
+/* add safely into STRBUF the string STR (which is first copied, so
+   can be in the basilys heap) */
+void basilysgc_add_strbuf (struct basilysstrbuf_st *strbuf_p,
+			   const char *str);
+/* add safely into STRBUF the string STR encoded as a C string with
+   backslash escapes */
+void basilysgc_add_strbuf_cstr (struct basilysstrbuf_st *strbuf_p,
+				const char *str);
+/* add safely into STRBUF the string STR encoded as the interior of a
+   C comment with slash star and star slash replaced by slash plus and
+   plus slash */
+void basilysgc_add_strbuf_ccomment (struct basilysstrbuf_st *strbuf_p,
+				    const char *str);
+
+/* add safely into STRBUF the string STR (which is copied at first)
+   encoded as a C identifier; ie non-alphanum begine encoded as an
+   underscore */
+void basilysgc_add_strbuf_cident (struct basilysstrbuf_st *strbuf_p,
+				  const char *str);
+
+/* add safely into STRBUF the initial prefix of string STR (which is
+   copied at first), with a length of at most PREFLEN encoded as a C
+   identifier; ie non-alphanum begine encoded as an underscore */
+void
+basilysgc_add_strbuf_cidentprefix (struct basilysstrbuf_st
+				   *strbuf_p, const char *str, int preflen);
+
+/* add safely into STRBUF the hex encoded number L */
+void basilysgc_add_strbuf_hex (struct basilysstrbuf_st *strbuf_p,
+			       unsigned long l);
+/* add safely into STRBUF the decimal encoded number L */
+void basilysgc_add_strbuf_dec (struct basilysstrbuf_st *strbuf_p, long l);
+
+/* add safely into STRBUF a printf like stuff with FMT */
+void
+basilysgc_strbuf_printf (struct basilysstrbuf_st *strbuf_p, const char *fmt,
+			 ...) ATTRIBUTE_PRINTF (2, 3);
+
+/* add safely into STRBUF either a space or an indented newline if the current line is bigger than the threshold */
+void basilysgc_strbuf_add_indent (struct basilysstrbuf_st *strbuf_p,
+				  int indeptn, int linethresh);
+
+/**************************** misc *****************************/
+/* a random generator */
+long basilys_lrand (void);
+
+static inline unsigned basilys_nonzerohash (void)
+{
+  unsigned h;
+  do
+    {
+      h = basilys_lrand () & BASILYS_MAXHASH;
+    }
+  while (h == 0);
+  return h;
+}
+
+/* initialize all - don't do anything when called more than once */
+void basilys_initialize (void);
+
+/* compile (as a dynamically loadable module) some (usually generated)
+   C code and dynamically load it; the C code should contain a
+   function named start_module_basilys; that function is called with
+   the given modata and returns the module */
+basilys_ptr_t
+basilysgc_compile_dyn (basilys_ptr_t modata_p, const char *srcfile);
+
+/* first_module_basilys is the function start_module_basilys in first-basilys.c */
+basilys_ptr_t first_module_basilys (basilys_ptr_t);
+
+
+/* get (or create) the symbol of a given name, using the TOKENIZER
+   global; the NAM string can be in the GC-allocated heap since it is
+   copied */
+enum
+{				/* a meningful enum for the create flag below */
+  BASILYS_GET = 0,
+  BASILYS_CREATE
+};
+
+basilys_ptr_t basilysgc_named_symbol (const char *nam, int create);
+
+/* get (or create) the keyword of a given name (without the colon),
+   using the TOKENIZER global; the NAM string can be in the
+   GC-allocated heap since it is copied */
+basilys_ptr_t basilysgc_named_keyword (const char *nam, int create);
+
+/* intern a symbol, ie add it into the global name map; if the symbol
+   is new, return it otherwise return the older homonymous symnol */
+basilys_ptr_t basilysgc_intern_symbol (basilys_ptr_t symb);
+
+/* intern a keyword, ie add it into the global name map; if the symbol
+   is new, return it otherwise return the older homonymous symnol */
+basilys_ptr_t basilysgc_intern_keyword (basilys_ptr_t symb);
+
+/* read a list of sexpressions from a file */
+basilys_ptr_t basilysgc_read_file (const char *filnam);
+
+/* Use basilys_assert(MESSAGE,EXPR) to test invariants.  The MESSAGE
+   should be a constant string displayed when asserted EXPR is
+   false */
+#if ENABLE_ASSERT_CHECKING
+void
+basilys_assert_failed (const char *msg, const char *filnam, int lineno,
+		       const char *fun)
+  ATTRIBUTE_NORETURN;
+enum { BASILYS_ANYWHERE=0, BASILYS_NOYOUNG };
+void  basilys_check_call_frames_at(int youngflag, const char*msg, const char*filenam, int lineno);
+#define basilys_assertmsg(MSG,EXPR)   \
+  (!(EXPR)?(basilys_assert_failed((MSG),__FILE__,__LINE__,__FUNCTION__), 0):0)
+#define basilys_check_call_frames(YNG,MSG)				\
+  ((void)(basilys_check_call_frames_at((YNG),(MSG),__FILE__,__LINE__)))
+#else
+/* Include EXPR, so that unused variable warnings do not occur.  */
+#define basilys_assertmsg(MSG,EXPR) ((void)(0 && (MSG) && (EXPR)))
+#define basilys_check_call_frames(YNG,MSG) (void)(0)
+#endif
+
+/******************* method sending ************************/
+basilys_ptr_t basilysgc_send (basilys_ptr_t recv,
+			      basilys_ptr_t sel,
+			      const char *xargdescr_,
+			      union basilysparam_un *xargtab_,
+			      const char *xresdescr_,
+			      union basilysparam_un *xrestab_);
+
+/**************************** globals **************************/
+
+/* enumeration of predefined global object indexes inside
+   basilys_globvec; the firsts are wired predefined, in the sense that
+   they are automagically allocated and partly filled before loading
+   the basilys file. The others are named, and are expected to be
+   created by loading the basilysfile  */
+enum basilys_globalix_en
+{
+  BGLOB__NONE,
+  /************************** wired predefined */
+  /***
+   * don't forget to fill these objects in basilys-init.bysl file
+   ***/
+  /* the pseudo discriminant using for sending to null pointers */
+  BGLOB_DISCR_NULLRECV,
+  /* the initial discriminant of string */
+  BGLOB_DISCR_STRING,
+  /* the initial discriminant of integer */
+  BGLOB_DISCR_INTEGER,
+  /* the initial discriminant of lists */
+  BGLOB_DISCR_LIST,
+  /* the initial discriminant of multiples */
+  BGLOB_DISCR_MULTIPLE,
+  /* the initial discriminant of boxes */
+  BGLOB_DISCR_BOX,
+  /* the initial discriminant of mapobjects */
+  BGLOB_DISCR_MAPOBJECTS,
+  /* the initial discriminant of mapstrings */
+  BGLOB_DISCR_MAPSTRINGS,
+  /* the initial discriminant of charcode integer */
+  BGLOB_DISCR_CHARINTEGER,
+  /* the initial discriminant of mixedint */
+  BGLOB_DISCR_MIXEDINT,
+  /* the discriminant of ancestors or other class sequences */
+  BGLOB_DISCR_SEQCLASS,
+  /* the discriminant of closures */
+  BGLOB_DISCR_CLOSURE,
+  /* the discriminant of routine */
+  BGLOB_DISCR_ROUTINE,
+  /* the discriminant of pairs */
+  BGLOB_DISCR_PAIR,
+  /* the discriminant of short name strings */
+  BGLOB_DISCR_NAMESTRING,
+  /* the discriminant of verbatim strings (in primitive expansions) */
+  BGLOB_DISCR_VERBATIMSTRING,
+  /* discriminant for sequence of fields */
+  BGLOB_DISCR_SEQFIELD,
+  /* discriminant for dictionnaries (mapobjects) of methods */
+  BGLOB_DISCR_METHODMAP,
+  /* the class of classes */
+  BGLOB_CLASS_CLASS,
+  /* the root class */
+  BGLOB_CLASS_ROOT,
+  /* the proped class */
+  BGLOB_CLASS_PROPED,
+  /* the named class */
+  BGLOB_CLASS_NAMED,
+  /* the located class */
+  BGLOB_CLASS_LOCATED,
+  /* the symbol class */
+  BGLOB_CLASS_SYMBOL,
+  /* the keyword class */
+  BGLOB_CLASS_KEYWORD,
+  /* the sexpr class */
+  BGLOB_CLASS_SEXPR,
+  /* class of fields */
+  BGLOB_CLASS_FIELD,
+  /* class of message selectors */
+  BGLOB_CLASS_SELECTOR,
+  /* class of primitives */
+  BGLOB_CLASS_PRIMITIVE,
+  /* class of formal bindings */
+  BGLOB_CLASS_FORMAL_BINDING,
+  /* the discr class */
+  BGLOB_CLASS_DISCR,
+  /* the class of tokenizers */
+  BGLOB_CLASS_TOKENIZER,
+  /* the class of command dispatchers */
+  BGLOB_CLASS_COMMAND_DISPATCHER,
+  /* atom for returning true */
+  BGLOB_ATOM_TRUE,
+  /**** every ctype should be predefined ****/
+  /* ctype of longs */
+  BGLOB_CTYPE_LONG,
+  /* ctype of values */
+  BGLOB_CTYPE_VALUE,
+  /* ctype of trees */
+  BGLOB_CTYPE_TREE,
+  /* ctype for void */
+  BGLOB_CTYPE_VOID,
+  /* ctype of constant cstrings */
+  BGLOB_CTYPE_CSTRING,
+  /* the global tokenizer */
+  BGLOB_TOKENIZER,
+  /* the initial command dispatcher */
+  BGLOB_INITIAL_COMMAND_DISPATCHER,
+  /**************************** placeholder for last wired */
+  BGLOB__LASTWIRED,
+  /*****/
+  BGLOB__LASTGLOB
+};
+
+
+/* *INDENT-OFF* */
+
+/* the array of global values */
+extern GTY (()) basilys_ptr_t basilys_globarr[BGLOB__LASTGLOB];
+
+/* *INDENT-ON* */
+
+/* fields inside every proped object */
+enum
+{
+  FPROPED_PROP = 0,
+  FPROPED__LAST
+};
+/* fields inside every named object */
+enum
+{
+  FNAMED_NAME = FPROPED__LAST,
+  FNAMED__LAST
+};
+
+/* fields inside every discriminant */
+enum
+{
+  FDISCR_METHODICT = FNAMED__LAST,	/* a mapobjects for method mapping
+					   selectors to closures */
+  FDISCR_SENDCLOSURE,		/* the closure doing the send if a
+				   selector is not in the method
+				   dict */
+  FDISCR_SUPER,			/* the "superclass" or "parent discrim" */
+  FDISCR__LAST
+};
+
+/* fields inside every class */
+enum
+{
+  FCLASS_ANCESTORS = FDISCR__LAST,	/* a multiple for the class ancestors
+					   (first being the CLASS:ROOT last
+					   being the immediate superclass) */
+  FCLASS_FIELDS,		/* a multiple for the class fields */
+  FCLASS_OBJNUMDESCR,		/* a description of the objnum */
+  FCLASS_DATA,			/* class variables */
+  FCLASS__LAST
+};
+
+
+/* fields inside each symbol */
+enum
+{
+  FSYMB_DATA = FNAMED__LAST,
+  FSYMB__LAST
+};
+
+/* fields inside a source expression (sexpr) */
+enum
+{
+  FSEXPR_LOCATION = FPROPED__LAST,
+  FSEXPR_CONTENTS,		/* the contents of the sexpression (as a list) */
+  FSEXPR__LAST
+};
+
+/* fields inside a tokenizer */
+enum
+{
+  FTOK_SYMBDICT = FNAMED__LAST,	/* the stringdict of symbols */
+  FTOK_KEYWDICT,		/* the stringdict of keywords */
+  FTOK_ADDSYMB,			/* closure to add a new symbol (given its name string) */
+  FTOK_ADDKEYW,			/* closure to add a new keyword */
+  FTOK_INTERNSYMB,		/* closure to intern a (freshly build) symbol */
+  FTOK_INTERNKEYW,		/* closure to intern a keyword */
+  FTOK__LAST
+};
+
+/* fields inside the command dispatcher */
+enum
+{
+  FCMDIS_FUNDICT = FNAMED__LAST,	/* the stringdict of commands */
+  FCMDIS__LAST
+};
+
+/* BASILYSG(Foo) is the global of index BGLOB_Foo */
+#define BASILYSG(Glob) basilys_globarr[BGLOB_##Glob]
+#define BASILYSGOB(Glob) ((basilysobject_ptr_t)(BASILYSG(Glob)))
+
+
+bool basilys_is_subclass_of (basilysobject_ptr_t subclass_p,
+			     basilysobject_ptr_t superclass_p);
+
+static inline bool
+basilys_is_instance_of (basilys_ptr_t inst_p, basilys_ptr_t class_p)
+{
+  unsigned mag_class = 0;
+  unsigned mag_inst = 0;
+  if (!inst_p)
+    return FALSE;
+  if (!class_p)
+    return FALSE;
+  gcc_assert(class_p->u_discr != NULL);
+  gcc_assert(inst_p->u_discr != NULL);
+  mag_class = class_p->u_discr->obj_num;
+  mag_inst = inst_p->u_discr->obj_num;
+  if (mag_class != OBMAG_OBJECT || !mag_inst)
+    return FALSE;
+  if (((basilysobject_ptr_t) inst_p)->obj_class ==
+      (basilysobject_ptr_t) class_p)
+    return TRUE;
+  if (mag_inst != ((basilysobject_ptr_t) class_p)->object_magic)
+    return FALSE;
+  if (mag_inst == OBMAG_OBJECT)
+    return basilys_is_subclass_of (((basilysobject_ptr_t) inst_p)->obj_class,
+				   ((basilysobject_ptr_t) class_p));
+  /* the instance is not an object but something else and it has the
+     good magic */
+  return TRUE;
+}
+
+/***
+ * CALL FRAMES 
+ ***/
+
+/* call frames for our copying garbage collector cannot be GTY-ed
+   because they are inside the C call stack */
+struct callframe_basilys_st
+{
+  unsigned nbvar;
+  struct basilysclosure_st *clos;
+  struct excepth_basilys_st *exh;	/* for our exceptions - not implemented yet */
+  struct callframe_basilys_st *prev;
+  basilys_ptr_t varptr[FLEXIBLE_DIM];
+};
+
+/* maximal number of local variables per frame */
+#define BASILYS_MAXNBLOCALVAR 4096
+
+/* the topmost call frame */
+extern struct callframe_basilys_st *basilys_topframe;
+
+#if 0
+/* the jmpbuf for our catch & throw */
+extern jmp_buf *basilys_jmpbuf;
+extern basilys_ptr_t basilys_jmpval;
+#endif
+
+/* declare the current callframe */
+#define BASILYS_DECLFRAME(NBVAR) struct {	\
+  unsigned nbvar;				\
+  struct basilysclosure_st* clos;		\
+  struct excepth_basilys_st* exh;               \
+  struct callframe_basilys_st* prev;		\
+  void*  /* a basilys_ptr_t */ varptr[NBVAR];	\
+} curfram__
+
+/* initialize the current callframe and link it at top */
+#define BASILYS_INITFRAME(NBVAR,CLOS) do {	\
+  memset(&curfram__, 0, sizeof(curfram__));	\
+  curfram__.nbvar = (NBVAR);			\
+  curfram__.prev = basilys_topframe;		\
+  curfram__.clos = (CLOS);			\
+  basilys_topframe = ((void*)&curfram__);	\
+} while(0)
+
+/* declare and initialize the current callframe */
+#define BASILYS_ENTERFRAME(NBVAR,CLOS) \
+  BASILYS_DECLFRAME(NBVAR); BASILYS_INITFRAME(NBVAR,CLOS)
+
+/* exit the current frame and return */
+#define BASILYS_EXITFRAME() do {		\
+  basilys_topframe = curfram__.prev;		\
+} while(0)
+
+/****
+#define BASILYS_CATCH(Vcod,Vptr) do {
+  jmp_buf __jbuf;
+  int __jcod;
+  jmp_buf* __prevj = basilys_jmpbuf;
+  memset(&__jbuf, 0, sizeof(jmp_buf));
+  basilys_jmpbuf = &__jbuf;
+  __jcod = setjmp(&__jbuf);
+  Vcod = __jcod;
+  if (__jcod) {
+    basilys_topframe = ((void*)&curfram__);
+    Vptr = basilys_jmpval;
+  };
+} while(0)
+
+#define BASILYS_THROW(Cod,Ptr) do {
+} while(0)
+***/
+
+
+/* ====== safer output routines ===== */
+
+/* output a string */
+static inline void
+basilys_puts (FILE * f, const char *str)
+{
+  if (f && str)
+    fputs (str, f);
+}
+
+/* output a number with a prefix & suffix message */
+static inline void
+basilys_putnum(FILE* f, const char*pref, long l, const char*suff) {
+  if (f) 
+    fprintf(f, "%s%ld%s", pref?pref:"", l, suff?suff:"");
+}
+
+/* safe flush */
+static inline void
+basilys_flush (FILE * f)
+{
+  if (f)
+    fflush (f);
+}
+
+/* safe newline and flush */
+static inline void
+basilys_newlineflush (FILE * f)
+{
+  if (f)
+    {
+      putc ('\n', f);
+      fflush (f);
+    }
+}
+
+/* output a string value */
+static inline void
+basilys_putstr (FILE * f, basilys_ptr_t sv)
+{
+  if (f && sv && basilys_magic_discr (sv) == OBMAG_STRING)
+    fputs (((struct basilysstring_st *) sv)->val, f);
+}
+
+/* output a string buffer */
+static inline void
+basilys_putstrbuf (FILE * f, basilys_ptr_t sb)
+{
+  struct basilysstrbuf_st *sbuf = (struct basilysstrbuf_st *) sb;
+  if (f && sbuf && basilys_magic_discr ((void *) sbuf) == OBMAG_STRBUF)
+    {
+      gcc_assert (sbuf->bufzn);
+      if (!sbuf->bufzn || sbuf->bufend <= sbuf->bufstart)
+	return;
+      fwrite (sbuf->bufzn + sbuf->bufstart, sbuf->bufend - sbuf->bufstart, 1,
+	      f);
+    }
+}
+
+
+/* output the declaration and implementation buffers of a generated file */
+void 
+basilys_output_cfile_decl_impl(basilys_ptr_t cfilnam, basilys_ptr_t declbuf, basilys_ptr_t implbuf);
+
+static inline void
+debugeputs_at (const char *fil, int lin, const char *msg)
+{
+  debugeprintf_raw ("!@%s:%d: %s\n", basename (fil), lin, msg);
+}
+
+#define debugeputs(Msg) debugeputs_at(__FILE__,__LINE__,(Msg))
+
+static inline void
+debugvalue_at (const char *fil, int lin, const char *msg, void *val)
+{
+  if (flag_basilys_debug)
+    {
+      fprintf (stderr, "!@%s:%d: %s @%p/%d= ",
+	       basename (fil), lin, (msg), val, basilys_magic_discr (val));
+      basilys_dbgeprint (val);
+      fflush (stderr);
+    }
+}
+
+#define debugvalue(Msg,Val) debugvalue_at(__FILE__, __LINE__, (Msg), (Val))
+
+static inline void
+debugbacktrace_at (const char *fil, int lin, const char *msg, int depth)
+{
+  if (flag_basilys_debug)
+    {
+      fprintf (stderr, "\n!@%s:%d: %s ** BACKTRACE** ",
+	       basename (fil), lin, msg);
+      basilys_dbgbacktrace (depth);
+      fflush (stderr);
+    }
+}
+
+#define debugbacktrace(Msg,Depth) debugbacktrace_at(__FILE__, __LINE__, (Msg), (Depth))
+
+static inline void
+debugnum_at (const char *fil, int lin, const char *msg, long val)
+{
+  debugeprintf_raw ("!@%s:%d: %s =#= %ld\n", basename (fil), lin, msg, val);
+}
+
+#define debugnum(Msg,Val) debugnum_at(__FILE__, __LINE__, (Msg), (Val))
+
+static inline void *
+basilys_globpredef (int rank)
+{
+  if (rank > 0 && rank < BGLOB__LASTGLOB)
+    return basilys_globarr[rank];
+  return NULL;
+}
+
+void basilys_dbgshortbacktrace(const char* msg, int maxdepth);
+
+#if ENABLE_CHECKING
+extern void* basilys_checkedp_ptr1;
+extern void* basilys_checkedp_ptr2;
+void basilys_caught_assign_at(void*ptr, const char*fil, int lin);
+#define basilys_checked_assign_at(Assign,Fil,Lin) ({			\
+      void* p_##Lin = (Assign);						\
+      if (p_##Lin && !basilys_discr(p_##Lin))				\
+	basilys_assert_failed("bad assign",Fil,Lin,__FUNCTION__);	\
+      if ( (p_##Lin == basilys_checkedp_ptr1 && p_##Lin)		\
+	   ||  (p_##Lin == basilys_checkedp_ptr2 && p_##Lin))		\
+	basilys_caught_assign_at(p_##Lin,Fil,Lin); p_##Lin; })
+#define basilys_checked_assign(Assign) basilys_checked_assign_at((Assign),__FILE__,__LINE__)
+void basilys_cbreak_at(const char*msg, const char*fil, int lin);
+#define basilys_cbreak(Msg) basilys_cbreak_at((Msg),__FILE__,__LINE__)
+#else
+#define basilys_checked_assign(Assign) Assign
+#define basilys_cbreak(Msg) ((void)(Msg))
+#endif /*ENABLE_CHECKING*/
+
+#endif /*BASILYS_INCLUDED_ */
+/* eof basilys.h */
diff --git a/gcc/common.opt b/gcc/common.opt
index 810f879fe48..15b0aa3c415 100644
--- a/gcc/common.opt
+++ b/gcc/common.opt
@@ -319,6 +319,37 @@ fauto-inc-dec
 Common Report Var(flag_auto_inc_dec) Init(1)
 Generate auto-inc/dec instructions
 
+;;;;;; basilys stuff
+; global GCC analysis by Basile (source file gcc/basilys.c)
+fbasilys
+Common Report Var(flag_basilys)  Condition(HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL)
+Perform whole program static analysis by Basile; require -fwhole-program
+
+; debug flag for above analysis
+fbasilys-debug
+Common Report Var(flag_basilys_debug)  Condition(HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL)
+Gives lots of debugging stuff for -fbasilys analysis
+
+; initial C file for above analysis
+fbasilys-init=
+Common Report Var(basilys_init_string) RejectNegative Joined  Condition(HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL)
+Initial file for -fbasilys analysis (dynamic C mode)
+
+; command for basilys
+fbasilys-command=
+Common Report Var(basilys_command_string) RejectNegative Joined  Condition(HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL)
+Initial command for basilys analysis 
+
+; argument string for basilys
+fbasilys-arg=
+Common Report Var(basilys_argument_string) RejectNegative Joined  Condition(HAVE_PARMAPOLY && HAVE_LIBTOOLDYNL)
+Initial argument for basilys analysis 
+
+
+
+
+;;;;;;;;;; end of basilys stuff
+
 ; -fcheck-bounds causes gcc to generate array bounds checks.
 ; For C, C++ and ObjC: defaults off.
 ; For Java: defaults to on.
@@ -370,6 +401,14 @@ fcommon
 Common Report Var(flag_no_common,0) Optimization
 Do not put uninitialized globals in the common section
 
+fcompiler-probe=
+Common Report Var(compiler_probe_string) RejectNegative Joined Condition(ENABLE_COMPILER_PROBE)
+Probe the compiler (using the comprobe protocol) with the given companion probing program
+
+fcompiler-probe-debug
+Common Report Var(flag_compiler_probe_debug)  RejectNegative  Condition(ENABLE_COMPILER_PROBE)
+Gives on stderr lot of debugging output for the compiler probe if enabled
+
 fcprop-registers
 Common Report Var(flag_cprop_registers) Optimization
 Perform a register copy-propagation optimization pass
diff --git a/gcc/compiler-probe.c b/gcc/compiler-probe.c
new file mode 100644
index 00000000000..6a7a5e0c922
--- /dev/null
+++ b/gcc/compiler-probe.c
@@ -0,0 +1,2078 @@
+/* Compiler probe
+   Copyright (C) 2007 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "regs.h"
+#include "timevar.h"
+#include "intl.h"
+#include "diagnostic.h"
+#include "hashtab.h"
+#include "tree.h"
+#include "tree-pass.h"
+#include "tree-flow.h"
+#include "tree-dump.h"
+#include "tree-inline.h"
+#include "tree-iterator.h"
+#include "diagnostic.h"
+#include "toplev.h"
+#include "ggc.h"
+#include "vec.h"
+#include "cgraph.h"
+#include "flags.h"
+#include "options.h"
+#include "safe-ctype.h"
+#include "basic-block.h"
+#include "rtl.h"
+#include "version.h"
+
+#include "compiler-probe.h"
+
+#if !defined(ENABLE_COMPILER_PROBE) || ENABLE_COMPILER_PROBE==0
+/* this file is linked in only if the compiler probe is enabled at
+   configure time */
+#error messy configuration: compiler-probe.c compiled but not enabled
+#endif
+
+const char *tree_code_names[] = {
+#define  DEFTREECODE(SYM, STRING, TYPE, NARGS) STRING,
+#include "tree.def"
+#undef DEFTREECODE
+  (char *) 0
+};
+
+
+#define debugeprintf_raw(Fmt,...) do{if (flag_compiler_probe_debug) \
+      {fprintf(stderr, Fmt, ##__VA_ARGS__); fflush(stderr);}}while(0)
+#define debugeprintf(Fmt,...) debugeprintf_raw("@!%s:%d: " Fmt "\n", \
+       basename(__FILE__), __LINE__, ##__VA_ARGS__)
+/* some debugeprintf give warnings so I disable them */
+#define nodebugeprintf(Fmt,...) do {}while(0)
+
+/* #define nodebugprintf debugprintf */
+
+#if ! defined( SIGCHLD ) && defined( SIGCLD )
+#  define SIGCHLD SIGCLD
+#endif
+
+/* set this flag on SIGIO */
+volatile sig_atomic_t comprobe_interrupted;
+
+int comprobe_bb_ok_rtl;		/* declared in basic-block.h */
+
+/* the probe command process */
+pid_t comprobe_pid;
+/* the command stream piped  into the compiler probe process */
+FILE *comprobe_replf;
+/* the file descriptor for requests from the probe process; it is never 0 */
+int comprobe_reqfd;
+
+
+
+/* grace delay in milliseconds for the compiler probe */
+#define PROBE_GRACE_DELAY_MS   250
+
+
+struct proberequest_buffer_st
+{
+  unsigned len;
+  unsigned used;
+  char str[1];			/* actual size is len, zero-terminated */
+};
+/* the buffer above is allocate in multiple of (should be a power of 2) : */
+#define PROBUF_GRAN 0x1000
+static struct proberequest_buffer_st *proberequest_buf;
+
+
+/* hash table for requests (from probe to compiler) handlers contain entries like */
+struct proberequesthentry_st
+{
+  const char *verb;		/* strdup-ed */
+  void *data;			/* explicitly allocated & freed by caller */
+  comprobe_requestfun_t *rout;
+};
+
+static htab_t proberequest_htable;
+
+
+/* filename are e.g. unix paths */
+typedef char *filename_t;
+/* hash table for filenames contain entries like */
+struct filenamehentry_st
+{
+  filename_t file;		/* strdup-ed filename */
+  int rank;			/* strictly positive rank in filename vector */
+};
+
+static htab_t filename_htable;
+
+/* *INDENT-OFF* */
+static GTY(()) VEC(tree,gc) *unique_tree_vector;
+static GTY(()) VEC(basic_block,gc) *unique_bb_vector;
+/* each tree of unique_tree_vector or basic_block of unique_bb_vector is
+   unique; we manage an hash table of indexes (>2) there. the index 0
+   is HTAB_EMPTY_ENTRY, the index 1 is HTAB_DELETED_ENTRY, the index 2
+   is for the seeked entry */
+static GTY (()) tree unique_seeked_tree;
+static GTY (()) basic_block unique_seeked_bb;
+/* *INDENT-ON* */
+/* hashtables of integer indexes into the unique_tree_vector & unique_bb_vector */
+static htab_t unique_tree_htable;
+static htab_t unique_bb_htable;
+#define HTAB_SEEKED_ENTRY ((PTR) 2)
+
+/***
+we would like to use vectors of filenames, but I cannot make them work
+   with GTY:
+       // see thread http://gcc.gnu.org/ml/gcc/2007-01/msg00172.html
+       DEF_VEC_P (filename_t); 
+       DEF_VEC_ALLOC_P (filename_t,heap); // don't work
+       VEC(filename_t,heap) *file_vector;
+ the gengtype parser choke on this with an error: unidentified type
+`filename_t'
+****/
+
+/* variable array of filenames */
+static struct
+{
+  int size;			/* allocated size */
+  int last;			/* last used index */
+  char **tab;
+} files_varr;
+
+struct displaychoice_st
+{
+  long di_magic;
+#define DI_MAGIC 2491573L
+  HOST_WIDE_INT di_data;
+  comprobe_infodisplay_fun_t *di_fun;
+  char di_msg[1];		/* duplicated display message
+				   - longer than 1 */
+};
+typedef struct displaychoice_st *displaychoice_ptr_t;
+/* *INDENT-OFF* */
+DEF_VEC_P (displaychoice_ptr_t);
+DEF_VEC_ALLOC_P (displaychoice_ptr_t, heap);
+
+struct comprobe_infodisplay_st {
+  int idis_num;			/* unique infodisplay number */
+  int idis_choice;			/* current display choice*/
+  struct infopointhentry_st* idis_infp;	/* the information point */
+  VEC(displaychoice_ptr_t,heap) *idis_navig; /* the navigation vector */
+  void*idis_data;		/* client data */
+  void (*idis_destroy)(struct comprobe_infodisplay_st*idi); /* destructor */
+};
+
+typedef struct comprobe_infodisplay_st* infodisplay_ptr_t;
+DEF_VEC_P(infodisplay_ptr_t);
+DEF_VEC_ALLOC_P(infodisplay_ptr_t,heap);
+static VEC(infodisplay_ptr_t,heap) *infodisplay_vector;
+
+/* the info point hashtable contains entries like : */
+struct infopointhentry_st
+{
+  int infp_filerank;	/* file rank */
+  int infp_lineno;		/* line number */
+  int infp_num;		/* unique infopoint number */
+  VEC(displaychoice_ptr_t,heap) *infp_dischvec;
+};
+typedef struct infopointhentry_st *infopoint_ptr_t;
+static htab_t infopoint_htable;
+DEF_VEC_P (infopoint_ptr_t);
+DEF_VEC_ALLOC_P (infopoint_ptr_t, heap);
+VEC (infopoint_ptr_t, heap) * infopoint_vector;
+/* *INDENT-ON* */
+
+/* random data for multiline replies */
+static struct drand48_data randata;
+
+
+/****
+ * supporting functions for probe reply hashtable 
+ *****/
+static hashval_t
+hash_proberequest (const void *d)
+{
+  const struct proberequesthentry_st *p = d;
+  return htab_hash_string (p->verb);
+}
+
+static int
+eq_proberequest (const void *dx, const void *dy)
+{
+  const struct proberequesthentry_st *px = dx;
+  const struct proberequesthentry_st *py = dy;
+  return !strcmp (px->verb, py->verb);
+}
+
+static void
+del_proberequest (void *d)
+{
+  struct proberequesthentry_st *p = d;
+  gcc_assert (p && p->verb);
+  free ((void *) p->verb);
+  p->verb = NULL;
+}
+
+
+
+/****
+ * supporting functions for filename hashtable 
+ *****/
+static hashval_t
+hash_filename (const void *d)
+{
+  const struct filenamehentry_st *p = d;
+  return htab_hash_string (p->file);
+}
+
+static int
+eq_filename (const void *dx, const void *dy)
+{
+  const struct filenamehentry_st *px = dx;
+  const struct filenamehentry_st *py = dy;
+  return !strcmp (px->file, py->file);
+}
+
+static void
+del_filename (void *d)
+{
+  struct filenamehentry_st *p = d;
+  gcc_assert (p && p->file && p->rank > 0);
+  free ((void *) p->file);
+  p->file = NULL;
+}
+
+/****
+ * supporting functions for infopoint hashtable 
+ *****/
+static hashval_t
+hash_infopoint (const void *d)
+{
+  const struct infopointhentry_st *ifp = d;
+  return (hashval_t)
+    (((long) (ifp->infp_filerank << 12)) ^ ((long) ifp->infp_lineno));
+}
+
+static int
+eq_infopoint (const void *dx, const void *dy)
+{
+  const struct infopointhentry_st *ifx = dx;
+  const struct infopointhentry_st *ify = dy;
+  return ifx->infp_lineno == ify->infp_lineno
+    && ifx->infp_filerank == ify->infp_filerank;
+}
+
+/***
+ * supporting functions for unique_tree_htable
+ ***/
+static hashval_t
+hash_info_tree (const void *d)
+{
+  comprobe_ix_t lg = (comprobe_ix_t) d;
+  switch (lg)
+    {
+    case (comprobe_ix_t) HTAB_EMPTY_ENTRY:
+    case (comprobe_ix_t) HTAB_DELETED_ENTRY:
+      return (hashval_t) 0;
+    case (comprobe_ix_t) HTAB_SEEKED_ENTRY:
+      lg = (comprobe_ix_t) unique_seeked_tree;
+      return (hashval_t) (lg ^ (lg >> 10));
+    default:
+      if (lg > 2 && unique_tree_vector
+	  && lg < VEC_length (tree, unique_tree_vector))
+	{
+	  lg = (comprobe_ix_t) VEC_index (tree, unique_tree_vector, lg);
+	  return (hashval_t) (lg ^ (lg >> 10));
+	};
+      return 0;
+    }
+}
+
+
+static int
+eq_info_tree (const void *dx, const void *dy)
+{
+  comprobe_ix_t lx = (comprobe_ix_t) dx;
+  comprobe_ix_t ly = (comprobe_ix_t) dy;
+  comprobe_ix_t nbtree = 0;
+  tree tx = NULL_TREE, ty = NULL_TREE;
+  if (lx == ly)
+    return 1;
+  if (unique_tree_vector)
+    nbtree = VEC_length (tree, unique_tree_vector);
+  else
+    return 0;
+  if (lx == (comprobe_ix_t) HTAB_SEEKED_ENTRY)
+    tx = unique_seeked_tree;
+  else if (lx > 2 && lx < nbtree)
+    tx = VEC_index (tree, unique_tree_vector, lx);
+  if (ly == (comprobe_ix_t) HTAB_SEEKED_ENTRY)
+    ty = unique_seeked_tree;
+  else if (ly > 2 && ly < nbtree)
+    ty = VEC_index (tree, unique_tree_vector, ly);
+  return tx == ty && tx != NULL_TREE;
+}
+
+
+comprobe_ix_t
+comprobe_unique_index_of_tree (tree tr)
+{
+  comprobe_ix_t trix = 0;
+  comprobe_ix_t l = 0, nbtree = 0;
+  void **sp = NULL;
+  if (tr == NULL_TREE)
+    return 0;
+  gcc_assert (unique_tree_vector
+	      && VEC_length (tree, unique_tree_vector) > 2);
+  l = (comprobe_ix_t) HTAB_SEEKED_ENTRY;
+  nbtree = VEC_length (tree, unique_tree_vector);
+  unique_seeked_tree = tr;
+  sp = htab_find_slot (unique_tree_htable, &l, INSERT);
+  if (sp)
+    {
+      if (*sp != HTAB_EMPTY_ENTRY && *sp != HTAB_DELETED_ENTRY
+	  && *sp != HTAB_SEEKED_ENTRY)
+	l = *(comprobe_ix_t *) (*sp);
+      else
+	l = 0;
+      if (l > 2)
+	{
+	  gcc_assert (l < nbtree
+		      && VEC_index (tree, unique_tree_vector, l) == tr);
+	  trix = l;
+	}
+      else
+	{
+	  VEC_safe_push (tree, gc, unique_tree_vector, tr);
+	  trix = nbtree;
+	  *(comprobe_ix_t *) (sp) = trix;
+	}
+    }
+  else				/* failed to insert into unique_tree_htable */
+    gcc_unreachable ();
+  return trix;
+}
+
+tree
+comprobe_tree_of_unique_index (comprobe_ix_t ix)
+{
+  unsigned nbtree = 0;
+  if (ix < 2 || !unique_tree_vector)
+    return 0;
+  nbtree = VEC_length (tree, unique_tree_vector);
+  if ((int) ix < (int) nbtree)
+    return VEC_index (tree, unique_tree_vector, ix);
+  return 0;
+}
+
+
+
+/***
+ * supporting functions for unique_bb_htable
+ ***/
+static hashval_t
+hash_info_bb (const void *d)
+{
+  comprobe_ix_t lg = (comprobe_ix_t) d;
+  switch (lg)
+    {
+    case (comprobe_ix_t) HTAB_EMPTY_ENTRY:
+    case (comprobe_ix_t) HTAB_DELETED_ENTRY:
+      return (hashval_t) 0;
+    case (comprobe_ix_t) HTAB_SEEKED_ENTRY:
+      lg = (comprobe_ix_t) unique_seeked_bb;
+      return (hashval_t) (lg ^ (lg >> 10));
+    default:
+      if (lg > 2 && unique_bb_vector
+	  && lg < VEC_length (basic_block, unique_bb_vector))
+	{
+	  lg = (comprobe_ix_t) VEC_index (basic_block, unique_bb_vector, lg);
+	  return (hashval_t) (lg ^ (lg >> 10));
+	};
+      return 0;
+    }
+}
+
+
+static int
+eq_info_bb (const void *dx, const void *dy)
+{
+  comprobe_ix_t lx = (comprobe_ix_t) dx;
+  comprobe_ix_t ly = (comprobe_ix_t) dy;
+  long nbbb = 0;
+  basic_block bx = NULL, by = NULL;
+  if (lx == ly)
+    return 1;
+  if (unique_bb_vector)
+    nbbb = VEC_length (basic_block, unique_bb_vector);
+  else
+    return 0;
+  if (lx == (comprobe_ix_t) HTAB_SEEKED_ENTRY)
+    bx = unique_seeked_bb;
+  else if (lx > 2 && lx < nbbb)
+    bx = VEC_index (basic_block, unique_bb_vector, lx);
+  if (ly == (comprobe_ix_t) HTAB_SEEKED_ENTRY)
+    by = unique_seeked_bb;
+  else if (ly > 2 && ly < nbbb)
+    by = VEC_index (basic_block, unique_bb_vector, ly);
+  return bx == by && bx != NULL;
+}
+
+/****
+ * register a reply verb
+ ****/
+static void
+comprobe_register_unchecked (const char *verb,
+			     comprobe_requestfun_t * handler, void *data)
+{
+  struct proberequesthentry_st slot;
+  struct proberequesthentry_st **slotptr;
+  hashval_t h;
+  memset (&slot, 0, sizeof (slot));
+  slot.verb = verb;
+  h = hash_proberequest (&slot);
+  slotptr = (struct proberequesthentry_st **)
+    htab_find_slot_with_hash (proberequest_htable, &slot, h, INSERT);
+  if (!slotptr)
+    fatal_error
+      ("compiler probe failed to register request verb %s (memory full): %m",
+       verb);
+  if (*slotptr == HTAB_EMPTY_ENTRY || (*slotptr) == HTAB_DELETED_ENTRY)
+    {
+      struct proberequesthentry_st *newslot;
+      newslot = xcalloc (sizeof (struct proberequesthentry_st), 1);
+      newslot->verb = xstrdup (verb);
+      newslot->rout = handler;
+      newslot->data = data;
+      *slotptr = newslot;
+    }
+  else
+    {
+      struct proberequesthentry_st *oldslot = *slotptr;
+      gcc_assert (!strcmp (oldslot->verb, verb));
+      oldslot->rout = handler;
+      oldslot->data = data;
+    }
+}
+
+
+/****
+ * register a verb (and check that it is alphanumerical) 
+ ****/
+void
+comprobe_register (const char *verb, comprobe_requestfun_t * handler,
+		   void *data)
+{
+  const char *pc;
+  if (!verb)
+    return;
+  if (!ISALPHA (verb[0]))
+    fatal_error ("compiler probe: invalid verb %s to register", verb);
+  for (pc = verb + 1; *pc; pc++)
+    if (!ISALNUM (*pc) && *pc != '_')
+      fatal_error ("compiler probe: invalid verb %s to register", verb);
+  comprobe_register_unchecked (verb, handler, data);
+}
+
+
+/****
+ * remove a registered verb  @@@@@@ HAS TO BE CODED
+ ****/
+void
+comprobe_unregister (const char *verb)
+{
+  gcc_assert (verb && *verb);
+  /* #warning to be written comprobe_unregister */
+  gcc_unreachable ();
+}
+
+
+void
+comprobe_infopoint_add_display (int infoptrank,
+				comprobe_infodisplay_fun_t * dispfun,
+				const char *msg, HOST_WIDE_INT data)
+{
+  infopoint_ptr_t infp = NULL;
+  displaychoice_ptr_t dch = NULL;
+  size_t msgl = 0;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("infopoint_add_display  infoptrank %d msg %s", infoptrank,
+		msg);
+  if (infoptrank < 0 || !infopoint_vector
+      || infoptrank >= (int) VEC_length (infopoint_ptr_t, infopoint_vector))
+    return;
+  infp = VEC_index (infopoint_ptr_t, infopoint_vector, infoptrank);
+  nodebugeprintf ("infopoint_add_display infp %p msg %s dispfun %p",
+		infp, msg, (void *) dispfun);
+  if (!infp || !msg || !dispfun)
+    return;
+  msgl = strlen (msg);
+  gcc_assert (infp->infp_num == infoptrank);
+  dch = xcalloc (sizeof (*dch) + msgl, 1);
+  dch->di_data = data;
+  dch->di_magic = DI_MAGIC;
+  dch->di_fun = dispfun;
+  memcpy (dch->di_msg, msg, msgl);
+  debugeprintf ("infopoint_add_display dch %p", (void*)dch);
+  VEC_safe_push (displaychoice_ptr_t, heap, infp->infp_dischvec, dch);
+}
+
+void
+comprobe_display_add_navigator (struct comprobe_infodisplay_st *idi,
+				comprobe_infodisplay_fun_t * navfun,
+				const char *msg, HOST_WIDE_INT data)
+{
+  displaychoice_ptr_t dch = NULL;
+  size_t msgl = 0;
+  gcc_assert (idi);
+  gcc_assert (msg);
+  if (!comprobe_replf)
+    return;
+  msgl = strlen (msg);
+  if (!idi->idis_navig)
+    idi->idis_navig = VEC_alloc (displaychoice_ptr_t, heap, 3);
+  dch = xcalloc (sizeof (*dch) + msgl, 1);
+  dch->di_data = data;
+  dch->di_fun = navfun;
+  dch->di_magic = DI_MAGIC;
+  memcpy (dch->di_msg, msg, msgl);
+  nodebugeprintf ("add_navigator display %d navfun %p msg '%s'",
+		idi->idis_num, (void *) navfun, msg);
+  VEC_safe_push (displaychoice_ptr_t, heap, idi->idis_navig, dch);
+}
+
+
+
+/****
+ * the SIGIO and SIGCHLD signal handler just sets a flag
+ ****/
+static void
+sig_interrupted (int sig)
+{
+  gcc_assert (sig != 0);
+  comprobe_interrupted = 1;
+}
+
+
+/****
+ * Create the probing process and set up the pipes to it. 
+ * Do not exchange anything yet 
+ ****/
+static void
+create_probe_process (void)
+{
+  /* the probe process */
+  pid_t probpid;
+  /* the pipes from probe to gcc, and from gcc to probe */
+  int pip2gcc[2], pip2probe[2];
+  const char *progarg[5];
+  if (comprobe_pid > 0 && comprobe_replf && comprobe_reqfd >= 0)
+    return;
+  /* we do not use the pex_* routines from liberty.h because the
+     compiler probe is quite specific to Linux and similar Unix
+     operating systems with SIGIO, select, .... (probably Solaris,
+     and recent *BSD should be ok) */
+  pip2gcc[0] = pip2gcc[1] = -1;
+  pip2probe[0] = pip2probe[1] = -1;
+  if (pipe (pip2gcc) || pipe (pip2probe))
+    fatal_error ("failed to create pipes for compiler probe: %m");
+  probpid = fork ();
+  if (probpid == (pid_t) 0)
+    {
+      /* child process */
+      int ifd;
+      signal (SIGIO, SIG_DFL);
+#ifdef SIGSEGV
+      signal (SIGSEGV, SIG_DFL);
+#endif
+#ifdef SIGINT
+      signal (SIGINT, SIG_DFL);
+#endif
+#ifdef SIGTERM
+      signal (SIGTERM, SIG_DFL);
+#endif
+#ifdef SIGQUIT
+      signal (SIGQUIT, SIG_DFL);
+#endif
+#define perror_exit(Msg) do{perror(Msg); exit(1);}while(0)
+      /* write-pipe from probe to gcc is our stdout */
+      if (pip2gcc[1] != STDOUT_FILENO)
+	{
+	  if (dup2 (pip2gcc[1], STDOUT_FILENO) < 0)
+	    perror_exit
+	      ("comprobe child process failed to dup2 pipe to stdout to gcc");
+	  (void) close (pip2gcc[1]);
+	}
+      /* read-pipe from gcc to probe is our stdin */
+      if (pip2probe[0] != STDIN_FILENO)
+	{
+	  if (dup2 (pip2probe[0], STDIN_FILENO) < 0)
+	    perror_exit
+	      ("comprobe child process failed to dup2 pipe to stdin from gcc");
+	  (void) close (pip2probe[0]);
+	}
+      /* close useless fds in the child before exec */
+      for (ifd = STDERR_FILENO + 1; ifd < 64; ifd++)
+	(void) close (ifd);
+      /* use sh -c for the compiler probe command */
+      memset (progarg, 0, sizeof (progarg));
+      progarg[0] = "sh";
+      progarg[1] = "-c";
+      progarg[2] = compiler_probe_string;
+      progarg[3] = (char *) 0;
+      execv ("/bin/sh", (char *const *) progarg);
+      perror_exit ("comprobe child process failed to exec /bin/sh");
+    }
+#undef perror_exit
+  else if (probpid < (pid_t) 0)
+    {
+      /* error fork failed */
+      fatal_error ("failed to fork for compiler probe: %m");
+    }
+  else
+    {				/* parent */
+      (void) close (pip2gcc[1]);
+      (void) close (pip2probe[0]);
+      comprobe_pid = probpid;
+      comprobe_replf = fdopen (pip2probe[1], "a");
+      comprobe_reqfd = pip2gcc[0];
+      if (!comprobe_replf)
+	fatal_error ("failed to open pipe stream to compiler probe: %m");
+      if (comprobe_reqfd <= 0)
+	{
+	  /* this should almost never happen; I could think it might
+	     happen if gcc is run without any open file descriptor - not
+	     even stdin; but I expect the request file descriptor to be
+	     positive */
+	  fatal_error ("failed to get pipe fd %d from compiler probe: %m",
+		       comprobe_reqfd);
+	};
+      if (fcntl (comprobe_reqfd, F_SETFL, (long) O_NONBLOCK) < 0)
+	fatal_error
+	  ("failed to make non-blocking the pipe fd %d from compiler probe: %m",
+	   comprobe_reqfd);
+      if (fcntl (comprobe_reqfd, F_SETOWN, (long) getpid ()) < 0)
+	fatal_error ("failed to SETOWN pipe fd %d from compiler probe: %m",
+		     comprobe_reqfd);
+      setlinebuf (comprobe_replf);
+      fprintf (stderr, "created compiler probe '%s' process %ld\n",
+	       compiler_probe_string, (long) comprobe_pid);
+    }
+}
+
+
+
+/****
+ * wait for the compiler probe process, returns 0 when waited successfully;
+ * if BLOCKING is set, wait indefinitely, otherwise just test without
+ * blocking
+ ****/
+static int
+wait_for_probe (int blocking, int *pstatus)
+{
+  int probstatus = 0;
+  gcc_assert (comprobe_pid > 0);
+#if HAVE_WAITPID || HAVE_SYS_WAIT_H
+  if (waitpid (comprobe_pid, &probstatus, blocking ? WNOHANG : 0) ==
+      comprobe_pid)
+    {
+      if (pstatus)
+	*pstatus = probstatus;
+      return 0;
+    }
+#elif HAVE_WAIT4
+  if (wait4
+      (comprobe_pid, &probstatus, blocking ? WNOHANG : 0,
+       (struct rusage *) 0) == comprobepid)
+    {
+      if (pstatus)
+	*pstatus = probstatus;
+      return 0;
+    };
+#else
+#error should have waitpid or wait4
+#endif
+  return 1;
+}
+
+/****
+ * output a string URL encoded wtih STR89' prefix for a string of 89
+ * chars and a ' suffix
+ ****/
+void
+comprobe_outenc_string (const char *s)
+{
+  int c, l;
+  if (!comprobe_replf || !s)
+    return;
+  l = strlen (s);
+  comprobe_printf ("STR%d'", l);
+  for (; (c = (*s)) != 0; s++)
+    {
+      if ((c >= 'A' && c <= 'Z')
+	  || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9'))
+	putc (c, comprobe_replf);
+      else
+	switch (c)
+	  {
+	  case ' ':
+	    putc ('+', comprobe_replf);
+	    break;
+	  case '*':
+	  case '/':
+	  case '_':
+	  case '@':
+	  case '-':
+	  case '(':
+	  case ')':
+	  case '!':
+	  case '[':
+	  case ']':
+	  case '.':
+	  case ',':
+	  case ';':
+	    putc (c, comprobe_replf);
+	    break;
+	  default:
+	    fprintf (comprobe_replf, "%%%02x", c & 0xff);
+	    break;
+	  }
+    }
+  putc ('\'', comprobe_replf);
+}
+
+/****
+ * process a single line of request (from probe to compiler) 
+ ****/
+static void
+process_request_line (struct comprobe_whatpos_st *wp, char *line)
+{
+  struct proberequesthentry_st *ptrslot;
+  struct proberequesthentry_st slot;
+  char *pc;
+  char *argreq;
+  if (line[0] == '#' || line[0] == 0)
+    return;
+  debugeprintf ("req.lin: %s", line);
+  memset (&slot, 0, sizeof (slot));
+  for (pc = line; ISALNUM (*pc) || *pc == '_'; pc++);
+  argreq = 0;
+  if (*pc)
+    argreq = pc + 1;
+  *pc = 0;
+  slot.verb = line;
+  ptrslot =
+    (struct proberequesthentry_st *) htab_find (proberequest_htable, &slot);
+  if (ptrslot && ptrslot->rout)
+    (*ptrslot->rout) (wp, argreq, ptrslot->data);
+  else
+    fprintf (stderr, "gcc compiler-probe don't understand request: %s\n",
+	     line);
+  debugeprintf ("req.lin done: %s", line);
+}
+
+/****
+ * stop the compiler probe 
+ ****/
+void
+comprobe_stop (void)
+{
+  int status = 0;
+  if (!compiler_probe_string || !compiler_probe_string[0] || !comprobe_pid)
+    return;
+  /* kill the probing process and wait for it nicely, first by closing the pipe to it */
+  fclose (comprobe_replf);
+  close (comprobe_reqfd);
+  /* give a little time to the probe */
+  usleep ((unsigned long) PROBE_GRACE_DELAY_MS * 1000);
+  if (wait_for_probe (0, &status))
+    {
+      (void) kill (comprobe_pid, SIGTERM);
+      while (!wait_for_probe (1, &status))
+	{
+	  usleep ((unsigned long) PROBE_GRACE_DELAY_MS * 1000);
+	  (void) kill (comprobe_pid, SIGQUIT);
+	};
+    };
+  fprintf (stderr, "ended compiler probe process %ld [status %d]:",
+	   (long) comprobe_pid, status);
+  if (WIFEXITED (status))
+    fprintf (stderr, "probe exited %d\n", WEXITSTATUS (status));
+  else if (WIFSIGNALED (status))
+    psignal (WTERMSIG (status),
+	     WCOREDUMP (status)
+	     ? "probe coredumped on signal" : "probe terminated with signal");
+  putc ('\n', stderr);
+  fflush (stderr);
+  comprobe_reqfd = -1;
+  comprobe_replf = (FILE *) 0;
+  comprobe_pid = 0;
+  compiler_probe_string = 0;
+  signal (SIGIO, SIG_DFL);
+  signal (SIGCHLD, SIG_DFL);
+}
+
+/* forced kill of probe - called only on unrecoverable errors */
+void
+comprobe_forced_kill (void)
+{
+  if (!compiler_probe_string || !compiler_probe_string[0]
+      || !comprobe_pid || !comprobe_replf)
+    return;
+  fflush (comprobe_replf);
+  (void) kill (comprobe_pid, SIGTERM);
+  comprobe_stop ();
+}
+
+/****
+ * read all probe requests, waiting for them for a delay in milliseconds 
+ * and process every newline terminated reply line
+ ****/
+static void
+read_probe_requests (struct comprobe_whatpos_st *wp, unsigned millisec)
+{
+  fd_set rdset;
+  struct timeval tv;
+  int maxfd = 0;
+  int selnb = 0;
+  if (comprobe_reqfd <= 0)
+    return;
+  /* flush the reply stream to send any pending stuff */
+  if (comprobe_replf)
+    fflush (comprobe_replf);
+  FD_ZERO (&rdset);
+  if (comprobe_reqfd >= 0)
+    FD_SET (comprobe_reqfd, &rdset);
+  maxfd = MAX (maxfd, comprobe_reqfd);
+  if (millisec >= 1000)
+    millisec = 999;
+  tv.tv_sec = 0;
+  tv.tv_usec = millisec * 1000;
+  selnb = select (maxfd + 1, &rdset, (fd_set *) 0, (fd_set *) 0, &tv);
+  if (selnb > 0 && FD_ISSET (comprobe_reqfd, &rdset))
+    {
+      int again = 0;
+      do
+	{
+	  int newsiz;
+	  int readcnt, readlen;
+	  if (comprobe_reqfd < 0)
+	    break;
+	  newsiz = 0;
+	  if (!proberequest_buf)
+	    newsiz = 2 * PIPE_BUF;
+	  else if (proberequest_buf->used + PIPE_BUF <= proberequest_buf->len)
+	    newsiz =
+	      (((5 * proberequest_buf->len / 4 + 2 * PIPE_BUF))
+	       | (PROBUF_GRAN - 1)) + 1;
+	  if (newsiz > 0)
+	    {
+	      struct proberequest_buffer_st *newbuf;
+	      newbuf = xcalloc (1,
+				sizeof (struct
+					proberequest_buffer_st) + newsiz - 1);
+	      newbuf->len = newsiz;
+	      if (proberequest_buf)
+		{
+		  gcc_assert (proberequest_buf->used <=
+			      proberequest_buf->len);
+		  memcpy (newbuf->str, proberequest_buf->str,
+			  proberequest_buf->used);
+		  newbuf->used = proberequest_buf->used;
+		  free (proberequest_buf);
+		};
+	      proberequest_buf = newbuf;
+	    };
+	  gcc_assert (proberequest_buf->used + PIPE_BUF <
+		      proberequest_buf->len);
+	  readlen = proberequest_buf->len - proberequest_buf->used - 1;
+	  readcnt = read (comprobe_reqfd,
+			  proberequest_buf->str + proberequest_buf->used,
+			  readlen);
+	  again = 0;
+	  if (readcnt == 0)
+	    {			/* got end of file on the probe reply pipe */
+	      again = 0;
+	      comprobe_stop ();
+	    }
+	  else if (readcnt < 0)
+	    {
+	      if (errno == EINTR)
+		again = 1;
+	      else if (errno == EAGAIN)
+		again = 0;
+	      else
+		fatal_error ("unexpected read error from compiler probe: %m");
+	    }
+	  else			/*readcnt>0 */
+	    {
+	      char *eol = 0;
+	      char *pc = 0;
+	      off_t off, rlen;
+	      proberequest_buf->used += readcnt;
+	      proberequest_buf->str[proberequest_buf->used] = 0;
+	      for (pc = proberequest_buf->str; (eol = strchr (pc, '\n')) != 0;
+		   pc = eol + 1)
+		{
+		  *eol = 0;
+		  process_request_line (wp, pc);
+		  if (comprobe_replf)
+		    fflush (comprobe_replf);
+		};
+	      off = pc - proberequest_buf->str;
+	      if (off > 0)
+		{
+		  rlen = proberequest_buf->str + proberequest_buf->used - pc;
+		  memmove (proberequest_buf->str, pc, rlen);
+		  proberequest_buf->str[rlen] = 0;
+		  proberequest_buf->used = rlen;
+		  if (proberequest_buf->len - rlen > 3 * PIPE_BUF)
+		    {
+		      unsigned newsiz =
+			((rlen + 2 * PIPE_BUF) | (PROBUF_GRAN - 1)) + 1;
+		      if (newsiz < proberequest_buf->len && newsiz > rlen)
+			{
+			  proberequest_buf =
+			    xrealloc (proberequest_buf, newsiz);
+			  proberequest_buf->len = newsiz;
+			}
+		    }
+		};
+	      again = 1;
+	    }
+	}
+      while (again);
+    }
+}
+
+/****
+ * handle a request (called by comprobe_check macro) 
+ ****/
+void
+comprobe_handle_probe (const char *what, const char *file, int lineno)
+{
+  struct comprobe_whatpos_st wp;
+  if (!compiler_probe_string || !compiler_probe_string[0]
+      || comprobe_pid <= 0)
+    return;
+  memset (&wp, 0, sizeof (wp));
+  wp.wp_what = what;
+  wp.wp_file = file;
+  wp.wp_line = lineno;
+  read_probe_requests (&wp, 0);
+}
+
+/****
+ * handle all requests until a given variable is cleared, or the probe ended 
+ ****/
+void
+comprobe_while_probe (const char *what, const char *file, int lineno,
+		      int *pvar)
+{
+  struct comprobe_whatpos_st wp;
+  if (comprobe_pid <= 0 || !pvar)
+    return;
+  memset (&wp, 0, sizeof (wp));
+  wp.wp_what = what;
+  wp.wp_file = file;
+  wp.wp_line = lineno;
+  while (comprobe_pid > 0 && *pvar)
+    {
+      read_probe_requests (&wp, PROBE_GRACE_DELAY_MS);
+    };
+}
+
+/***
+ * big commands are uniquely bracketed 
+ ***/
+static long leftcode, rightcode;
+void
+comprobe_begin_big (void)
+{
+  gcc_assert (leftcode == 0 && rightcode == 0);
+  if (!comprobe_replf)
+    return;
+  do
+    {
+      lrand48_r (&randata, &leftcode);
+    }
+  while (leftcode == 0);
+  do
+    {
+      lrand48_r (&randata, &rightcode);
+    }
+  while (rightcode == 0);
+  fprintf (comprobe_replf, "\n!#%x/%X[\n",
+	   (int) (leftcode & 0xfffffff), (int) (rightcode & 0xfffffff));
+}
+
+void
+comprobe_end_big (void)
+{
+  gcc_assert (leftcode != 0 && rightcode != 0);
+  if (comprobe_replf)
+    {
+      fprintf (comprobe_replf, "\n!#%x/%X]\n",
+	       (int) (leftcode & 0xfffffff), (int) (rightcode & 0xfffffff));
+      fflush (comprobe_replf);
+    }
+  leftcode = rightcode = 0;
+}
+
+
+static int nonstopped;
+
+/* the STOP request from probe stops properly the probe */
+static void
+stop_reqfun (struct comprobe_whatpos_st *wp ATTRIBUTE_UNUSED,
+	     char *reqlin ATTRIBUTE_UNUSED, void *data ATTRIBUTE_UNUSED)
+{
+  if (comprobe_replf)
+    fflush (comprobe_replf);
+  nonstopped = 0;
+  comprobe_stop ();
+}
+
+static int
+cmp_displaychoice_ptr (const void *x, const void *y)
+{
+  displaychoice_ptr_t dx = *(displaychoice_ptr_t *) x;
+  displaychoice_ptr_t dy = *(displaychoice_ptr_t *) y;
+  return strcmp (dx->di_msg, dy->di_msg);
+}
+
+/* the NEWINFODIALOG request from probe make a new dialog for an infopoint */
+static void
+newinfodialog_reqfun (struct comprobe_whatpos_st *wp ATTRIBUTE_UNUSED,
+		      char *reqlin, void *data ATTRIBUTE_UNUSED)
+{
+  int infork = -1, dialrk = -1, nbdisp = 0, chix = 0;
+  infopoint_ptr_t ip = NULL;
+  infodisplay_ptr_t idisp = NULL;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("newinfodialog_reqfun reqlin: %s", reqlin);
+  if (sscanf (reqlin, " pt: %d dia: %d", &infork, &dialrk) < 2
+      || infork < 0 || dialrk < 0)
+    return;
+  debugeprintf ("newinfodialog_reqfun infork=%d dialrk=%d", infork, dialrk);
+  if (infork >= (int) VEC_length (infopoint_ptr_t, infopoint_vector))
+    return;
+  ip = VEC_index (infopoint_ptr_t, infopoint_vector, infork);
+  if (!ip)
+    return;
+  if ((int) VEC_length (infodisplay_ptr_t, infodisplay_vector) <= dialrk)
+    VEC_safe_grow_cleared (infodisplay_ptr_t, heap, infodisplay_vector,
+			   5 * dialrk / 4 + 16);
+  idisp = xcalloc (sizeof (*idisp), 1);
+  idisp->idis_num = dialrk;
+  idisp->idis_infp = ip;
+  VEC_replace (infodisplay_ptr_t, infodisplay_vector, dialrk, idisp);
+  /* sort the display choices in alphanumerical order */
+  if (ip->infp_dischvec)
+    nbdisp = VEC_length (displaychoice_ptr_t, ip->infp_dischvec);
+  debugeprintf ("newinfodialog_reqfun nbdisp=%d", nbdisp);
+  if (nbdisp > 0)
+    qsort ((VEC_address (displaychoice_ptr_t, ip->infp_dischvec)),
+	   (size_t) nbdisp, sizeof (displaychoice_ptr_t),
+	   cmp_displaychoice_ptr);
+  for (chix = 0; chix < nbdisp; chix++)
+    {
+      displaychoice_ptr_t dch =
+	VEC_index (displaychoice_ptr_t, ip->infp_dischvec, chix);
+      gcc_assert (dch && dch->di_fun);
+      gcc_assert (dch->di_magic == DI_MAGIC);
+      comprobe_printf ("PROB_dialogchoice dia:%d msg:", dialrk);
+      comprobe_outenc_string (dch->di_msg);
+      comprobe_printf (" ch:%d\n", chix);
+    };
+  comprobe_printf ("PROB_showdialog dia:%d\n", dialrk);
+  comprobe_flush ();
+}
+
+static void bb_starting_displayer (struct comprobe_whatpos_st *wp,
+				   struct comprobe_infodisplay_st *di,
+				   HOST_WIDE_INT data, HOST_WIDE_INT navig);
+
+static void tree_starting_displayer (struct comprobe_whatpos_st *wp,
+				     struct comprobe_infodisplay_st *di,
+				     HOST_WIDE_INT data, HOST_WIDE_INT navig);
+
+static void tree_ending_displayer (struct comprobe_whatpos_st *wp,
+				   struct comprobe_infodisplay_st *di,
+				   HOST_WIDE_INT data, HOST_WIDE_INT navig);
+
+static void
+display_tree (tree tr, struct comprobe_infodisplay_st *di)
+{
+  gcc_assert (di != 0);
+  if (!tr)
+    comprobe_printf ("*** NULL TREE %p ***\n", (void*)tr);
+  else if (GIMPLE_STMT_P (tr))
+    {
+      comprobe_printf ("*** GIMPLE STMT %p ***\n", (void*)tr);
+      print_generic_stmt_indented (comprobe_replf, tr,
+				   TDF_LINENO | TDF_VOPS | TDF_MEMSYMS |
+				   TDF_UID, 1);
+    }
+  else if (EXPR_P (tr))
+    {
+      comprobe_printf ("*** EXPR %p ***\n", (void*)tr);
+      print_generic_expr (comprobe_replf, tr,
+			  TDF_LINENO | TDF_VOPS | TDF_MEMSYMS);
+    }
+  else if (TREE_CODE (tr) == STATEMENT_LIST)
+    {
+      tree_stmt_iterator tsi;
+      int rk = 0;
+      comprobe_printf ("*** STATEMENT LIST %p ***\n", (void*)tr);
+      print_generic_expr (comprobe_replf, tr,
+			  TDF_LINENO | TDF_VOPS | TDF_MEMSYMS);
+      for (tsi = tsi_start (tr); !tsi_end_p (tsi); tsi_next (&tsi))
+	{
+	  tree stmt = tsi_stmt (tsi);
+	  rk++;
+	  if (stmt)
+	    {
+	      static char titbuf[64];
+	      memset (titbuf, 0, sizeof (titbuf));
+	      snprintf (titbuf, sizeof (titbuf) - 1, "%d-th substmt", rk);
+	      comprobe_display_add_navigator (di, tree_starting_displayer,
+					      titbuf,
+					      comprobe_unique_index_of_tree
+					      (stmt));
+	    }
+
+	}
+    }
+  else
+    comprobe_printf ("*** tree of code %d <%s>***\n",
+		     TREE_CODE (tr), tree_code_names[TREE_CODE (tr)]);
+  if (TREE_CODE (tr) == PHI_NODE)
+    {
+      basic_block bb = PHI_BB (tr);
+      if (bb)
+	{
+	  comprobe_ix_t bbix = comprobe_unique_index_of_basic_block (bb);
+	  comprobe_display_add_navigator (di, bb_starting_displayer,
+					  "phi node basic block", bbix);
+	}
+    }
+}
+
+static void
+tree_starting_displayer (struct comprobe_whatpos_st *wp,
+			 struct comprobe_infodisplay_st *di,
+			 HOST_WIDE_INT data,
+			 HOST_WIDE_INT navig ATTRIBUTE_UNUSED)
+{
+  tree tr = NULL_TREE;
+  comprobe_ix_t ix = (comprobe_ix_t) data;
+  unsigned nbtree = VEC_length (tree, unique_tree_vector);
+  debugeprintf ("tree_starting_displayer ix %d nbtree %d", (int) ix,
+		(int) nbtree);
+  if (ix > 0 && ix < (long) nbtree)
+    {
+      tr = VEC_index (tree, unique_tree_vector, ix);
+      comprobe_printf
+	("// starting tree_%ld #%d shown when '%s' \n// from gcc file %s line %d\n",
+	 ix, di->idis_infp->infp_num, wp->wp_what, basename (wp->wp_file),
+	 wp->wp_line);
+      display_tree (tr, di);
+    }
+  else
+    comprobe_printf
+      (" ?? invalid starting tree index %ld nbtree %d info #%d??", (long) ix,
+       (int) nbtree, di->idis_infp->infp_num);
+}
+
+static void
+tree_ending_displayer (struct comprobe_whatpos_st *wp,
+		       struct comprobe_infodisplay_st *di,
+		       HOST_WIDE_INT data,
+		       HOST_WIDE_INT navig ATTRIBUTE_UNUSED)
+{
+  tree tr = NULL_TREE;
+  comprobe_ix_t ix = (comprobe_ix_t) data;
+  unsigned nbtree = VEC_length (tree, unique_tree_vector);
+  debugeprintf ("tree_ending_displayer ix %d nbtree %d", (int) ix,
+		(int) nbtree);
+  if (ix > 0 && ix < (long) nbtree)
+    {
+      tr = VEC_index (tree, unique_tree_vector, ix);
+      comprobe_printf
+	("// ending tree_%ld #%d shown when '%s'\n// from gcc file %s line %d\n",
+	 (long) ix, di->idis_infp->infp_num, wp->wp_what,
+	 basename (wp->wp_file), wp->wp_line);
+      display_tree (tr, di);
+    }
+  else
+    comprobe_printf (" ?? invalid ending tree index %ld nbtree %d info #%d??",
+		     (long) ix, (int) nbtree, di->idis_infp->infp_num);
+}
+
+
+static void
+bb_starting_displayer (struct comprobe_whatpos_st *wp,
+		       struct comprobe_infodisplay_st *di,
+		       HOST_WIDE_INT data,
+		       HOST_WIDE_INT navig ATTRIBUTE_UNUSED)
+{
+  comprobe_ix_t ix = (comprobe_ix_t) data;
+  char pfx[24];
+  basic_block bb = NULL;
+  debugeprintf ("bb_starting_displayer ix %d", (int) ix);
+  comprobe_bb_ok_rtl = 1;
+  if (ix > 0 && ix < VEC_length (basic_block, unique_bb_vector))
+    {
+      bb = VEC_index (basic_block, unique_bb_vector, ix);
+      comprobe_printf
+	("// starting basic block _%ld #%d shown when '%s' \n// from gcc file %s line %d\n",
+	 (long) ix, di->idis_infp->infp_num, wp->wp_what,
+	 basename (wp->wp_file), wp->wp_line);
+      snprintf (pfx, sizeof (pfx), "[+bb#%d] ", di->idis_infp->infp_num);
+      comprobe_printf ("\n// basic block info _%ld #%d is\n",
+		       (long) ix, di->idis_infp->infp_num);
+      dump_bb_info (bb, true, true,
+		    TDF_DETAILS | TDF_LINENO | TDF_VOPS | TDF_MEMSYMS,
+		    pfx, comprobe_replf);
+      if (phi_nodes(bb))
+	{
+	  comprobe_printf ("\n// basic block phi_nodes _%ld #%d is\n",
+			   ix, di->idis_infp->infp_num);
+	  display_tree (phi_nodes(bb), di);
+	  comprobe_display_add_navigator
+	    (di, tree_starting_displayer,
+	     "phi nodes", comprobe_unique_index_of_tree (phi_nodes(bb)));
+	};
+      if (bb_stmt_list(bb))
+	{
+	  comprobe_printf ("\n// basic block stmt_list _%ld #%d is\n", ix,
+			   di->idis_infp->infp_num);
+	  display_tree (bb_stmt_list(bb), di);
+	  comprobe_display_add_navigator
+	    (di, tree_starting_displayer,
+	     "stmt list", comprobe_unique_index_of_tree (bb_stmt_list(bb)));
+	};
+    }
+  else
+    comprobe_printf ("?? invalid starting basic block index %ld info #%d??",
+		     ix, di->idis_infp->infp_num);
+  comprobe_bb_ok_rtl = 0;
+}
+
+static void
+bb_ending_displayer (struct comprobe_whatpos_st *wp,
+		     struct comprobe_infodisplay_st *di,
+		     HOST_WIDE_INT data, HOST_WIDE_INT navig ATTRIBUTE_UNUSED)
+{
+  comprobe_ix_t ix = (comprobe_ix_t) data;
+  char pfx[24];
+  basic_block bb = NULL;
+  int infoptrk = di->idis_infp->infp_num;
+  debugeprintf ("bb_ending_displayer ix %d", (int) ix);  
+  comprobe_bb_ok_rtl = 1;
+  if (ix > 0 && ix < VEC_length (basic_block, unique_bb_vector))
+    {
+      bb = VEC_index (basic_block, unique_bb_vector, ix);
+      comprobe_printf
+	("// ending basic block _%ld #%d shown when '%s'\n// from gcc file %s line %d\n",
+	 ix, infoptrk, wp->wp_what, basename (wp->wp_file), wp->wp_line);
+      snprintf (pfx, sizeof (pfx), "[-bb#%d] ", infoptrk);
+      dump_bb_info (bb, true, true,
+		    TDF_DETAILS | TDF_LINENO | TDF_VOPS | TDF_MEMSYMS,
+		    pfx, comprobe_replf);
+    }
+  else
+    comprobe_printf ("?? invalid ending basic block index %ld info #%d??", ix,
+		     infoptrk);  
+  comprobe_bb_ok_rtl = 0;
+}
+
+/* clear the navigation vector inside a display */
+static void
+infodialog_clear_navig (infodisplay_ptr_t disp)
+{
+  int navix = 0;
+  displaychoice_ptr_t navch = NULL;
+  debugeprintf ("infodialog_clear_navig disp %p num %d", (void*)disp,
+		disp->idis_num);
+  if (disp->idis_navig)
+    {
+      for (navix = 0;
+	   VEC_iterate (displaychoice_ptr_t, disp->idis_navig, navix,
+			navch); navix++)
+	{
+	  if (!navch)
+	    continue;
+	  gcc_assert (navch->di_magic == DI_MAGIC);
+	  VEC_replace (displaychoice_ptr_t, disp->idis_navig, navix, NULL);
+	  memset (navch, 0, sizeof (navch));
+	  free (navch);
+	}
+      VEC_free (displaychoice_ptr_t, heap, disp->idis_navig);
+      disp->idis_navig = NULL;
+    }
+}
+
+
+static void
+fill_infodialog (struct comprobe_whatpos_st *wp, infodisplay_ptr_t disp,
+		 displaychoice_ptr_t ch, comprobe_ix_t chix)
+{
+  debugeprintf("fill_infodialog ch %p chix %d", (void*)ch, (int)chix);
+  gcc_assert (ch && ch->di_magic == DI_MAGIC);
+  infodialog_clear_navig (disp);
+  if (ch->di_fun)
+    {
+      comprobe_begin_big_printf ("PROB_dialogcontent dia:%d\n",
+				 disp->idis_num);
+      (*ch->di_fun) (wp, disp, ch->di_data, chix);
+      comprobe_end_big ();
+      if (disp->idis_navig
+	  && VEC_length (displaychoice_ptr_t, disp->idis_navig) > 0)
+	{
+	  int navix = 0;
+	  displaychoice_ptr_t navch = NULL;
+	  for (navix = 0;
+	       VEC_iterate (displaychoice_ptr_t, disp->idis_navig, navix,
+			    navch); navix++)
+	    {
+	      gcc_assert (navch->di_magic == DI_MAGIC);
+	      debugeprintf ("fill_infodialog %d navix %d navch msg '%s'",
+			    disp->idis_num, navix, navch->di_msg);
+	      comprobe_printf ("PROB_dialognavig dia:%d msg:",
+			       disp->idis_num);
+	      comprobe_outenc_string (navch->di_msg);
+	      comprobe_printf (" nav:%d\n", navix);
+	    }
+	}
+      comprobe_printf ("PROB_showdialog dia:%d\n", disp->idis_num);
+      comprobe_flush ();
+    }
+  else debugeprintf("fill_infodialog no function in ch %p", (void*)ch);
+}
+
+
+/* the SHOWINFODIALOG request from probe ask for the dialog to be shown */
+static void
+showinfodialog_reqfun (struct comprobe_whatpos_st *wp,
+		       char *reqlin, void *data ATTRIBUTE_UNUSED)
+{
+  int dialrk = -1, chrk = -1;
+  infodisplay_ptr_t disp = NULL;
+  infopoint_ptr_t ip = NULL;
+  displaychoice_ptr_t ch = NULL;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("showinfodialog_reqfun reqlin: %s", reqlin);
+  if (sscanf (reqlin, " dia: %d ch: %d", &dialrk, &chrk) < 2
+      || chrk < 0 || dialrk < 0)
+    return;
+  if (!infodisplay_vector
+      || dialrk >= (int) VEC_length (infodisplay_ptr_t, infodisplay_vector))
+    return;
+  disp = VEC_index (infodisplay_ptr_t, infodisplay_vector, dialrk);
+  if (!disp)
+    return;
+  gcc_assert (disp->idis_num == dialrk);
+  ip = disp->idis_infp;
+  gcc_assert (ip);
+  if (chrk >= (int) VEC_length (displaychoice_ptr_t, ip->infp_dischvec))
+    return;
+  ch = VEC_index (displaychoice_ptr_t, ip->infp_dischvec, chrk);
+  if (!ch)
+    return;
+  gcc_assert (ch->di_magic == DI_MAGIC);
+  disp->idis_choice = chrk;
+  debugeprintf ("showinfodialog_reqfun ch %p str= %s", (void*)ch, ch->di_msg);
+  fill_infodialog (wp, disp, ch, -1);
+  debugeprintf ("showinfodialog_reqfun end reqlin: %s", reqlin);
+}
+
+
+static void
+updateinfodialog_reqfun (struct comprobe_whatpos_st *wp,
+			 char *reqlin, void *data ATTRIBUTE_UNUSED)
+{
+  int dialrk = -1;
+  infodisplay_ptr_t disp = NULL;
+  infopoint_ptr_t ip = NULL;
+  displaychoice_ptr_t ch = NULL;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("updateinfodialog_reqfun reqlin: %s", reqlin);
+  if (sscanf (reqlin, " dia: %d", &dialrk) <= 0 || dialrk < 0)
+    return;
+  if (!infodisplay_vector
+      || dialrk >= (int) VEC_length (infodisplay_ptr_t, infodisplay_vector))
+    return;
+  disp = VEC_index (infodisplay_ptr_t, infodisplay_vector, dialrk);
+  if (!disp)
+    return;
+  gcc_assert (disp->idis_num == dialrk);
+  ip = disp->idis_infp;
+  if (disp->idis_choice >= 0
+      && disp->idis_choice <
+      (int) VEC_length (displaychoice_ptr_t, ip->infp_dischvec))
+    ch =
+      VEC_index (displaychoice_ptr_t, ip->infp_dischvec, disp->idis_choice);
+  if (!ch) {
+    debugeprintf("updateinfodialog_reqfun no ch %p", (void*)ch);
+    return;
+  };
+  gcc_assert (ch->di_magic == DI_MAGIC);
+  debugeprintf ("updateinfodialog_reqfun ch %p str= %s", (void*)ch, ch->di_msg);
+  fill_infodialog (wp, disp, ch, -1);
+  debugeprintf ("updateinfodialog_reqfun end reqlin: %s", reqlin);
+}
+
+static void
+naviginfodialog_reqfun (struct comprobe_whatpos_st *wp,
+			char *reqlin, void *data ATTRIBUTE_UNUSED)
+{
+  int dialrk = -1, navrk = -1;
+  infodisplay_ptr_t disp = NULL;
+  infopoint_ptr_t ip = NULL;
+  displaychoice_ptr_t ch = NULL;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("naviginfodialog_reqfun reqlin: %s", reqlin);
+  if (sscanf (reqlin, " dia: %d nav: %d", &dialrk, &navrk) <= 0
+      || dialrk < 0 || navrk < 0)
+    return;
+  if (!infodisplay_vector
+      || dialrk >= (int) VEC_length (infodisplay_ptr_t, infodisplay_vector))
+    return;
+  disp = VEC_index (infodisplay_ptr_t, infodisplay_vector, dialrk);
+  debugeprintf ("naviginfodialog_reqfun disp %p", (void*)disp);
+  if (!disp)
+    return;
+  gcc_assert (disp->idis_num == dialrk);
+  ip = disp->idis_infp;
+  if (navrk < (int) VEC_length (displaychoice_ptr_t, disp->idis_navig))
+    ch = VEC_index (displaychoice_ptr_t, disp->idis_navig, navrk);
+  if (!ch)
+    return;
+  debugeprintf ("naviginfodialog_reqfun ch %p navrk %d", (void*)ch, navrk);
+  gcc_assert (ch->di_magic == DI_MAGIC);
+  debugeprintf ("naviginfodialog_reqfun ch %p str= %s", (void*)ch, ch->di_msg);
+  fill_infodialog (wp, disp, ch, navrk);
+  debugeprintf ("naviginfodialog_reqfun end reqlin: %s\n", reqlin);
+}
+
+static void
+removeinfodialog_reqfun (struct comprobe_whatpos_st *wp ATTRIBUTE_UNUSED,
+			 char *reqlin, void *data ATTRIBUTE_UNUSED)
+{
+  int dialrk = -1;
+  infodisplay_ptr_t disp = NULL;
+  if (!comprobe_replf)
+    return;
+  debugeprintf ("removeinfodialog_reqfun reqlin: %s", reqlin);
+  if (sscanf (reqlin, " dia: %d", &dialrk) <= 0 || dialrk < 0)
+    return;
+  if (!infodisplay_vector
+      || dialrk >= (int) VEC_length (infodisplay_ptr_t, infodisplay_vector))
+    return;
+  disp = VEC_index (infodisplay_ptr_t, infodisplay_vector, dialrk);
+  if (!disp)
+    return;
+  gcc_assert (disp->idis_num == dialrk);
+  infodialog_clear_navig (disp);
+  free (disp);
+  VEC_replace (infodisplay_ptr_t, infodisplay_vector, dialrk, 0);
+  comprobe_printf ("PROB_destroydialog dia:%d\n", dialrk);
+  comprobe_flush ();
+  debugeprintf ("removeinfodialog_reqfun end reqlin: %s", reqlin);
+}
+
+/****
+ * send a message to be shown
+ ****/
+void
+comprobe_show_message (const char *msg)
+{
+  if (!msg || !comprobe_replf)
+    return;
+  comprobe_puts ("PROB_message msg:");
+  comprobe_outenc_string (msg);
+  comprobe_puts ("\n");
+  comprobe_flush ();
+}
+
+
+/****
+ * Initialize the probe. Called from toplev.c
+ ****/
+void
+comprobe_initialize (void)
+{
+  static int inited;
+  long seed = 0;
+  const char *pc;
+  const char* randomseed = get_random_seed(false);
+  gcc_assert (!inited);
+  gcc_assert (randomseed != (char *) 0);
+  inited = 1;
+  if (!compiler_probe_string || !compiler_probe_string[0])
+    return;
+  for (pc = randomseed; *pc; pc++)
+    seed ^= (seed << 5) + (*pc);
+  srand48_r ((long) seed, &randata);
+  signal (SIGIO, sig_interrupted);
+  signal (SIGCHLD, sig_interrupted);
+  proberequest_htable =
+    htab_create (113, hash_proberequest, eq_proberequest, del_proberequest);
+  filename_htable =
+    htab_create (229, hash_filename, eq_filename, del_filename);
+  infopoint_htable = htab_create (2081, hash_infopoint, eq_infopoint, NULL);
+  infopoint_vector = VEC_alloc (infopoint_ptr_t, heap, 2048);
+  unique_tree_vector = VEC_alloc (tree, gc, 1024);
+  unique_bb_vector = VEC_alloc (basic_block, gc, 512);
+  /* reserve but don't use the first 4 entries hence HTAB_SEEKED_ENTRY unused */
+  VEC_safe_push (tree, gc, unique_tree_vector, (tree) 0);
+  VEC_safe_push (tree, gc, unique_tree_vector, (tree) 0);
+  VEC_safe_push (tree, gc, unique_tree_vector, (tree) 0);
+  VEC_safe_push (tree, gc, unique_tree_vector, (tree) 0);
+  VEC_safe_push (basic_block, gc, unique_bb_vector, (basic_block) 0);
+  VEC_safe_push (basic_block, gc, unique_bb_vector, (basic_block) 0);
+  VEC_safe_push (basic_block, gc, unique_bb_vector, (basic_block) 0);
+  VEC_safe_push (basic_block, gc, unique_bb_vector, (basic_block) 0);
+  unique_tree_htable = htab_create (4007, hash_info_tree, eq_info_tree, NULL);
+  unique_bb_htable = htab_create (3001, hash_info_bb, eq_info_bb, NULL);
+  files_varr.tab = XNEWVEC (char *, 100);
+  files_varr.size = 100;
+  files_varr.last = 0;
+  memset (files_varr.tab, 0, sizeof (char **) * files_varr.size);
+  comprobe_register ("prob_NAVIGINFODIALOG", naviginfodialog_reqfun, (void *) 0);
+  comprobe_register ("prob_NEWINFODIALOG", newinfodialog_reqfun, (void *) 0);
+  comprobe_register ("prob_REMOVEINFODIALOG", removeinfodialog_reqfun, (void *) 0);
+  comprobe_register ("prob_SHOWINFODIALOG", showinfodialog_reqfun, (void *) 0);
+  comprobe_register ("prob_STOP", stop_reqfun, (void *) 0);
+  comprobe_register ("prob_UPDATEINFODIALOG", updateinfodialog_reqfun, (void *) 0);
+  create_probe_process ();
+  comprobe_printf ("PROB_version proto:%d msg:", COMPROBE_PROTOCOL_NUMBER);
+  comprobe_outenc_string (version_string);
+  comprobe_puts ("\n");
+  comprobe_flush ();
+  atexit (comprobe_forced_kill);
+}
+
+/****
+ * Finish the probe. Called from toplev.c
+ ****/
+void
+comprobe_finish (void)
+{
+  nonstopped = 1;
+  comprobe_puts ("PROB_message msg:");
+  comprobe_outenc_string ("probe finished");
+  comprobe_puts ("\n");
+  comprobe_flush ();
+  comprobe_while ("finishing", &nonstopped);
+  comprobe_stop ();
+  if (proberequest_htable)
+    {
+      htab_empty (proberequest_htable);
+      htab_delete (proberequest_htable);
+      proberequest_htable = 0;
+    };
+  if (filename_htable)
+    {
+      htab_empty (filename_htable);
+      htab_delete (filename_htable);
+      filename_htable = 0;
+    };
+}
+
+
+
+int
+comprobe_file_rank (const char *filename)
+{
+  struct filenamehentry_st slot;
+  struct filenamehentry_st **slotptr = 0;
+  int filerank = 0;
+
+  if (!filename || !comprobe_replf)
+    return 0;
+  memset (&slot, 0, sizeof (slot));
+  slot.file = (char *) filename;
+  slotptr = (struct filenamehentry_st **)
+    htab_find_slot (filename_htable, &slot, INSERT);
+  if (!slotptr)
+    fatal_error
+      ("compiler probe failed to register file %s (memory full): %m",
+       filename);
+  if (*slotptr == HTAB_EMPTY_ENTRY || (*slotptr) == HTAB_DELETED_ENTRY)
+    {
+      struct filenamehentry_st *newslot = 0;
+      const char *dupfilename = xstrdup (filename);
+      newslot = xcalloc (sizeof (*newslot), 1);
+      if (files_varr.last + 1 >= files_varr.size)
+	{
+	  int newsiz = ((5 * files_varr.last) / 4 + 50) | 0x1f;
+	  int ix;
+	  char **newarr = XNEWVEC (char *, newsiz);
+	  newarr[0] = 0;
+	  for (ix = files_varr.last; ix > 0; ix--)
+	    newarr[ix] = files_varr.tab[ix];
+	  for (ix = files_varr.last + 1; ix < newsiz; ix++)
+	    newarr[ix] = (char *) 0;
+	  memset (files_varr.tab, 0, sizeof (char *) * files_varr.size);
+	  XDELETEVEC (files_varr.tab);
+	  files_varr.tab = newarr;
+	}
+      /* dont use index 0 */
+      filerank = ++files_varr.last;
+      files_varr.tab[filerank] = (char *) dupfilename;
+      gcc_assert (filerank > 0);
+      newslot->file = (char *) dupfilename;
+      newslot->rank = filerank;
+      *slotptr = newslot;
+      debugeprintf ("new file rank filerank%d file %s newslot %p", filerank,
+		    dupfilename, (void*)newslot);
+      comprobe_printf ("PROB_file rank:%d fpath:", filerank);
+      comprobe_outenc_string(dupfilename);
+      comprobe_puts("\n");
+      comprobe_flush();
+    }
+  else
+    {
+      struct filenamehentry_st *oldslot = *slotptr;
+      filerank = oldslot->rank;
+      gcc_assert (!strcmp (files_varr.tab[filerank], filename));
+      debugeprintf ("old file rank filerank%d file %s oldslot %p", filerank,
+		    filename, (void*)oldslot);
+    }
+  return filerank;
+}
+
+
+int
+comprobe_infopoint_rank (int filerank, int lineno)
+{
+  int inforank = 0;
+  struct infopointhentry_st slot;
+  struct infopointhentry_st **slotptr = 0;
+  gcc_assert (filerank > 0 && filerank <= files_varr.last);
+  gcc_assert (lineno > 0);
+  gcc_assert (infopoint_vector != NULL);
+  memset (&slot, 0, sizeof (slot));
+  slot.infp_filerank = filerank;
+  slot.infp_lineno = lineno;
+  slotptr = (struct infopointhentry_st **)
+    htab_find_slot (infopoint_htable, &slot, INSERT);
+  if (!slotptr)
+    fatal_error
+      ("compiler probe failed to register infopoint filerank=%d,lineno=%d (memory full): %m",
+       filerank, lineno);
+  if (*slotptr == HTAB_EMPTY_ENTRY || (*slotptr) == HTAB_DELETED_ENTRY)
+    {
+      struct infopointhentry_st *newslot = 0;
+      newslot = xcalloc (sizeof (*newslot), 1);
+      /* dont use index 0 */
+      if (VEC_length (infopoint_ptr_t, infopoint_vector) == 0)
+	VEC_safe_push (infopoint_ptr_t, heap, infopoint_vector,
+		       (struct infopointhentry_st *) 0);
+      VEC_safe_push (infopoint_ptr_t, heap, infopoint_vector, newslot);
+      inforank = VEC_length (infopoint_ptr_t, infopoint_vector) - 1;
+      comprobe_printf ("PROB_infopoint fil:%d lin:%d rk:%d\n", filerank,
+		       lineno, inforank);
+      comprobe_flush ();
+      newslot->infp_filerank = filerank;
+      newslot->infp_lineno = lineno;
+      newslot->infp_num = inforank;
+      newslot->infp_dischvec = VEC_alloc (displaychoice_ptr_t, heap, 3);
+      debugeprintf
+	("new infopoint slot filerank%d lineno%d inforank%d slot%p", filerank,
+	 lineno, inforank, (void*) newslot);
+      *slotptr = newslot;
+    }
+  else
+    {
+      struct infopointhentry_st *oldslot = (*slotptr);
+      gcc_assert (oldslot->infp_filerank == filerank
+		  && oldslot->infp_lineno == lineno);
+      inforank = oldslot->infp_num;
+      gcc_assert (inforank >= 0
+		  && inforank < (int) VEC_length (infopoint_ptr_t,
+						  infopoint_vector));
+      gcc_assert (VEC_index (infopoint_ptr_t, infopoint_vector, inforank)
+		  == oldslot);
+      debugeprintf
+	("old infopoint slot filerank%d lineno%d inforank%d oldslot%p",
+	 filerank, lineno, inforank, (void*)oldslot);
+    }
+  return inforank;
+}
+
+
+
+/***
+ * return true if a (GIMPLE/SSA) tree TR has a position 
+ * and in that case fill the PFILENAME and PLINENO
+ * if the END flag is set, return the last position
+ ***/
+bool
+comprobe_get_position (tree tr, char **pfilename, int *plineno, int end)
+{
+  if (CAN_HAVE_LOCATION_P (tr) && EXPR_HAS_LOCATION (tr))
+    {
+      char *pfile = (char *) EXPR_FILENAME (tr);
+      if (pfile)
+	{
+	  *pfilename = pfile;
+	  *plineno = EXPR_LINENO (tr);
+	  return TRUE;
+	}
+    }
+  else if (TREE_CODE (tr) == STATEMENT_LIST)
+    {
+      tree_stmt_iterator iter;
+      tree tr_stmt;
+      if (end)
+	{
+	  for (iter = tsi_last (tr); !tsi_end_p (iter); tsi_prev (&iter))
+	    {
+	      tr_stmt = tsi_stmt (iter);
+	      if (comprobe_get_position
+		  (tr_stmt, pfilename, plineno, POS_END))
+		return TRUE;
+	    }
+	}
+      else
+	for (iter = tsi_start (tr); !tsi_end_p (iter); tsi_next (&iter))
+	  {
+	    tr_stmt = tsi_stmt (iter);
+	    if (comprobe_get_position
+		(tr_stmt, pfilename, plineno, POS_START))
+	      return TRUE;
+	  }
+    }
+  else if (GIMPLE_STMT_P (tr))
+    {
+      char *pfile = (char *) EXPR_FILENAME (tr);
+      if (pfile)
+	{
+	  *pfilename = pfile;
+	  *plineno = EXPR_LINENO (tr);
+	  return TRUE;
+	}
+    }
+  else if (GIMPLE_TUPLE_P (tr) && GIMPLE_TUPLE_HAS_LOCUS_P (tr))
+    {
+      /* @@@@ dont know yet how to get location of a tuple */
+      gcc_unreachable ();
+    }
+  return FALSE;
+}
+
+int
+comprobe_file_rank_of_tree (tree tr, int *plineno)
+{
+  char *filename = 0;
+  int lineno = 0, filerank = 0;
+  if (!tr)
+    return 0;
+  if (!comprobe_get_position (tr, &filename, &lineno, POS_START))
+    return 0;
+  filerank = comprobe_file_rank (filename);
+  if (filerank > 0 && plineno)
+    *plineno = lineno;
+  return filerank;
+}
+
+
+/* run the compiler probe pass only if we have a real probe */
+static bool
+gate_comprobe (void)
+{
+  return comprobe_replf != (FILE *) 0 && comprobe_pid != (pid_t) 0;
+}
+
+
+/* add information point and display start of a given tree TR with
+   string DMESG - return the infopoint rank  */
+static int
+added_infopoint_display_tree (tree tr, const char *dmesg)
+{
+  int frk = 0, lin = 0, infrk = 0;
+  comprobe_ix_t trix = 0;
+  debugeprintf ("added_infopoint_display_tree tr+ %p dmesg %s", (void*)tr, dmesg);
+  if (!tr)
+    return 0;
+  frk = comprobe_file_rank_of_tree (tr, &lin);
+  if (frk > 0 && lin > 0)
+    {
+      trix = comprobe_unique_index_of_tree (tr);
+      gcc_assert (trix > 2);
+      infrk = comprobe_infopoint_rank (frk, lin);
+      debugeprintf
+	("added_infopoint_display_tree infrk%d frk%d lin%d tree %p dmesg %s",
+	 infrk, frk, lin, (void*)tr, dmesg);
+      comprobe_infopoint_add_display (infrk, tree_starting_displayer, dmesg,
+				      (HOST_WIDE_INT) trix);
+      return infrk;
+    };
+  return 0;
+}
+
+
+/* add information point for a given function body */
+static void
+add_infopoint_funbody (tree tr_body)
+{
+  int frk_body = 0, lin_body = 0;
+  debugeprintf ("add_infopoint_funbody tr_body %p start", (void*)tr_body);
+  frk_body = comprobe_file_rank_of_tree (tr_body, &lin_body);
+  if (frk_body >= 0 && lin_body > 0)
+    {
+      int esnumins = 0;
+      char *endfile = 0;
+      /* @@@ should probably dynamically allocate the message buffer */
+      static char msgbuf[200];
+      int endline = -1, endfrk = -1, infendnum = -1;
+      comprobe_ix_t trix = 0;
+      int infstartnum = -1;
+      infstartnum = comprobe_infopoint_rank (frk_body, lin_body);
+      if (comprobe_get_position (tr_body, &endfile, &endline, POS_END)
+	  && (endfrk = comprobe_file_rank (endfile)) >= 0)
+	infendnum = comprobe_infopoint_rank (endfrk, endline);
+      trix = comprobe_unique_index_of_tree (tr_body);
+      esnumins = estimate_num_insns (tr_body, &eni_inlining_weights);
+      debugeprintf
+	("add_infopoint_funbody tr%p infstartnum%d lin_body%d infendnum%d endline%d",
+	 (void*)tr_body, infstartnum, lin_body, infendnum, endline);
+      if (infstartnum > 0 && lin_body > 0)
+	{
+	  memset (msgbuf, 0, sizeof (msgbuf));
+	  if (frk_body == endfrk && endline > lin_body)
+	    snprintf (msgbuf, sizeof (msgbuf) - 1,
+		      _("starting body of %d lines & %d instrs"),
+		      endline - lin_body, esnumins);
+	  else
+	    snprintf (msgbuf, sizeof (msgbuf) - 1,
+		      _("starting body of %d instrs"), esnumins);
+	  if (added_infopoint_display_tree (tr_body, msgbuf) != infstartnum)
+	    gcc_unreachable ();
+	}
+      if (infendnum > 0 && endline > 0)
+	{
+	  memset (msgbuf, 0, sizeof (msgbuf));
+	  if (frk_body == endfrk && endline > lin_body && lin_body > 0)
+	    snprintf (msgbuf,
+		      sizeof (msgbuf) - 1,
+		      _("ending body of %d lines & %d instrs"),
+		      endline - lin_body, esnumins);
+	  else
+	    snprintf (msgbuf,
+		      sizeof (msgbuf) - 1,
+		      _("ending body of %d instrs"), esnumins);
+	  comprobe_infopoint_add_display
+	    (infendnum, tree_ending_displayer, msgbuf, (HOST_WIDE_INT) trix);
+	}
+    }
+  debugeprintf ("add_infopoint_funbody tr_body %p end", (void*)tr_body);
+}
+
+
+comprobe_ix_t
+comprobe_unique_index_of_basic_block (basic_block bb)
+{
+  comprobe_ix_t bbix = 0;
+  comprobe_ix_t l = 0, nbbb = 0;
+  void **sp = 0;
+  if (bb == NULL || !unique_bb_vector)
+    return 0;
+  gcc_assert (unique_bb_vector
+	      && VEC_length (basic_block, unique_bb_vector) > 2);
+  l = (comprobe_ix_t) HTAB_SEEKED_ENTRY;
+  nbbb = VEC_length (basic_block, unique_bb_vector);
+  unique_seeked_bb = bb;
+  sp = htab_find_slot (unique_bb_htable, &l, INSERT);
+  if (sp)
+    {
+      if (*sp != HTAB_EMPTY_ENTRY && *sp != HTAB_DELETED_ENTRY
+	  && *sp != HTAB_SEEKED_ENTRY)
+	l = *(comprobe_ix_t *) (*sp);
+      else
+	l = 0;
+      if (l > 2)
+	{
+	  gcc_assert (l < nbbb
+		      && VEC_index (basic_block, unique_bb_vector, l) == bb);
+	  bbix = l;
+	}
+      else
+	{
+	  VEC_safe_push (basic_block, gc, unique_bb_vector, bb);
+	  bbix = nbbb;
+	  *(comprobe_ix_t *) (sp) = bbix;
+	}
+    }
+  else				/* failed to insert into unique_bb_htable */
+    gcc_unreachable ();
+  return bbix;
+}
+
+
+basic_block
+comprobe_basic_block_of_unique_index (comprobe_ix_t ix)
+{
+  int nbbb = 0;
+  if (ix < 2 || !unique_bb_vector)
+    return NULL;
+  nbbb = VEC_length (basic_block, unique_bb_vector);
+  if ((long) ix < (long) nbbb)
+    return VEC_index (basic_block, unique_bb_vector, ix);
+  return NULL;
+}
+
+/* add information point for a given basic block */
+static void
+add_infopoint_basic_block (basic_block bb)
+{
+  block_stmt_iterator bsi;
+  int stmtcnt = 0;
+  comprobe_ix_t bbix = 0;
+  bool bbgotpos = 0;
+  debugeprintf ("add_infopoint_basic_block bb %p start", (void*)bb);
+  if (bb == NULL)
+    return;
+  bbix = comprobe_unique_index_of_basic_block (bb);
+  gcc_assert (bbix > 2);
+  bbgotpos = FALSE;
+  for (bsi = bsi_start (bb); !bsi_end_p (bsi); bsi_next (&bsi))
+    {
+      tree stmt = bsi_stmt (bsi);
+      char *filename = 0;
+      int lineno = 0;
+      int filrk = 0, infrk = 0;
+      static char msgbuf[64];
+      if (stmt)
+	stmtcnt++;
+      else
+	continue;
+      if (comprobe_get_position (stmt, &filename, &lineno, POS_START))
+	{
+	  filrk = comprobe_file_rank (filename);
+	  infrk = comprobe_infopoint_rank (filrk, lineno);
+	  if (!bbgotpos)
+	    {
+	      bbgotpos = TRUE;
+	      memset (msgbuf, 0, sizeof (msgbuf));
+	      snprintf (msgbuf,
+			sizeof (msgbuf) - 1, "start bb#%d", bb->index);
+	      comprobe_infopoint_add_display
+		(infrk, bb_starting_displayer, msgbuf, (HOST_WIDE_INT) bbix);
+	    };
+	  memset (msgbuf, 0, sizeof (msgbuf));
+	  snprintf (msgbuf,
+		    sizeof (msgbuf) - 1, "stmt#%d bb#%d", stmtcnt, bb->index);
+	  (void) added_infopoint_display_tree (stmt, msgbuf);
+	}
+    }
+  for (bsi = bsi_last (bb); !bsi_end_p (bsi); bsi_prev (&bsi))
+    {
+      tree stmt = bsi_stmt (bsi);
+      char *filename = 0;
+      int lineno = 0;
+      int filrk = 0, infrk = 0;
+      static char msgbuf[64];
+      if (comprobe_get_position (stmt, &filename, &lineno, POS_END))
+	{
+	  filrk = comprobe_file_rank (filename);
+	  infrk = comprobe_infopoint_rank (filrk, lineno);
+	  memset (msgbuf, 0, sizeof (msgbuf));
+	  snprintf (msgbuf, sizeof (msgbuf) - 1, "end bb#%d", bb->index);
+	  comprobe_infopoint_add_display
+	    (infrk, bb_ending_displayer, msgbuf, (HOST_WIDE_INT) bbix);
+	  break;
+	}
+    };
+  debugeprintf ("add_infopoint_basic_block bb %p end", (void*)bb);
+}
+
+
+/* this function does the bulk of the work of the pass and returns
+   additional TODOs to the pass machinery */
+static unsigned int
+execute_comprobe (void)
+{
+  struct cgraph_node *cgr_fun = 0;
+  basic_block bb = 0;
+  for (cgr_fun = cgraph_nodes; cgr_fun; cgr_fun = cgr_fun->next)
+    {
+      tree tr_decl, tr_body;
+      int frk_decl = 0, lin_decl = 0;
+      if (!comprobe_replf)
+	break;
+      debugeprintf ("execute_comprobe cgr_fun=%p", (void*)cgr_fun);
+      if (flag_compiler_probe_debug)
+	dump_cgraph_node (stderr, cgr_fun);
+      tr_decl = cgr_fun->decl;
+      frk_decl = comprobe_file_rank_of_tree (tr_decl, &lin_decl);
+      tr_body = DECL_SAVED_TREE (tr_decl);
+      if (!tr_body)
+	continue;
+      comprobe_check ("comprobe cgraph loop");
+      add_infopoint_funbody (tr_body);
+      comprobe_flush ();
+    }
+  FOR_EACH_BB (bb)
+  {
+    if (!comprobe_replf)
+      break;
+    debugeprintf ("execute_comprobe bb %p", (void*)bb);
+    if (!bb_stmt_list(bb))
+      continue;
+    comprobe_check ("comprobe bb loop");
+    add_infopoint_basic_block (bb);
+    comprobe_flush ();
+  }
+  comprobe_flush ();
+  return 0;			/* no additional todos */
+}
+
+struct tree_opt_pass pass_compiler_probe = {
+  "comprobe",			/* name */
+  gate_comprobe,		/* gate */
+  execute_comprobe,		/* execute */
+  NULL,				/* sub */
+  NULL,				/* next */
+  0,				/* static_pass_number */
+  0,				/* tv_id */
+  0 /*PROP_cfg | PROP_ssa */ ,	/* properties_required */
+  0,				/* properties_provided */
+  0,				/* properties_destroyed */
+  0,				/* todo_flags_start */
+  0,				/* todo_flags_finish */
+  0				/* letter */
+};
+
+#include "gt-compiler-probe.h"
+/* eof compiler-probe.c */
diff --git a/gcc/compiler-probe.h b/gcc/compiler-probe.h
new file mode 100644
index 00000000000..1f5aa0b34b8
--- /dev/null
+++ b/gcc/compiler-probe.h
@@ -0,0 +1,482 @@
+/* Compiler probe.
+   Copyright (C) 2007 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch  <basile@starynkevitch.net>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GCC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#ifndef GCC_COMPILER_PROBE_H
+#define GCC_COMPILER_PROBE_H
+
+#define COMPROBE_PROTOCOL_NUMBER 200701
+
+/* the compiler probe */
+#if defined(ENABLE_COMPILER_PROBE) && ENABLE_COMPILER_PROBE
+/* <unistd.h> and <fcntl.h> and <string.h> have already been included
+   and the following includes have been checked by autoconf */
+#include <sys/select.h>
+#include <signal.h>
+
+/* compiler-probe.c uses the comprobe_ prefix */
+
+struct comprobe_whatpos_st
+{
+  const char *wp_what;
+  const char *wp_file;
+  int wp_line;
+};
+
+/* handling routine for a request (from probe to compiler) */
+typedef void comprobe_requestfun_t (struct comprobe_whatpos_st *wp,
+				    char *reqlin, void *data);
+
+/****
+ * the interrupt flag, its handler, and the macro to check it 
+ ****/
+extern volatile sig_atomic_t comprobe_interrupted;
+
+void comprobe_handle_probe (const char *what, const char *file, int lineno);
+
+/* this macro should be put at all the points where we want to permit
+   compiler probe interaction; in the common case where
+   comprobe_interrupted is cleared, this macro runs quite quickly */
+#define comprobe_check(WHAT) do{ if (comprobe_interrupted) { \
+      comprobe_handle_probe((WHAT),__FILE__,__LINE__); }} while(0)
+
+/***
+ * stop the compiler probe (can be called from action handler)
+ ***/
+void comprobe_stop (void);
+
+/***
+ * forced kill of the compiler probe
+ ***/
+void comprobe_forced_kill (void);
+
+/* force probing till an integer variable is cleared or the probe ended */
+void comprobe_while_probe (const char *what, const char *file, int lineno,
+			   int *pvar);
+#define comprobe_while(WHAT,PVAR) do{ \
+    comprobe_while_probe((WHAT),__FILE__,__LINE__,(PVAR));}while(0)
+/***
+ * the stream for replying to the probe ; may be NULL so should be tested!
+ ***/
+extern FILE *comprobe_replf;
+#define comprobe_printf(Fmt, ...) do{if(comprobe_replf) {	\
+      fprintf(comprobe_replf, (Fmt), ##__VA_ARGS__);		\
+      fflush(comprobe_replf);}}while(0)
+#define comprobe_puts(S) do{if(comprobe_replf) {	\
+      fputs((S), comprobe_replf);			\
+      fflush(comprobe_replf);}}while(0)
+#define comprobe_flush() do{if(comprobe_replf)	\
+      fflush(comprobe_replf); } while(0)
+void comprobe_begin_big (void);
+void comprobe_end_big (void);
+void comprobe_outenc_string (const char *s);
+#define comprobe_begin_big_printf(Fmt, ...) do{if(comprobe_replf) {	\
+      comprobe_begin_big(); fprintf(comprobe_replf, (Fmt), \
+				    ##__VA_ARGS__);}}while(0)
+/***
+ * initialize and finish. called in toplev.c 
+ ****/
+void comprobe_initialize (void);
+void comprobe_finish (void);
+
+
+/****
+ * send a message to be shown
+ ****/
+void comprobe_show_message (const char *msg);
+
+
+extern struct tree_opt_pass pass_compiler_probe;
+
+/***
+ * return a unique positive file rank for a file path; or 0 for NULL name
+ *  may send a PROB_file request to the probe
+ ***/
+int comprobe_file_rank (const char *filename);
+
+/***
+ * return a unique positive infopoint rank for a file rank and a line
+ * number; may send a PROB_file request and a PROB_infopoint request
+ * to the probe
+ **/
+int comprobe_infopoint_rank (int filrank, int lineno);
+
+/***
+ * return the linenumber, filerank, and filename of a given infopoint
+ * or O|NULL if invalid infopoint rank
+ ***/
+int comprobe_line_of_infopoint (int infoptrank);
+int comprobe_filerank_of_infopoint (int infoptrank);
+const char *comprobe_filename_of_infopoint (int infoptrank);
+
+/***
+ * infopoint displayer routines
+ ***/
+
+/* info displayers are opaque structures managed by the compiler probe */
+struct comprobe_infodisplay_st;
+
+typedef void comprobe_infodisplay_fun_t
+  (struct comprobe_whatpos_st *wp,
+   struct comprobe_infodisplay_st *di,
+   HOST_WIDE_INT data, HOST_WIDE_INT navig);
+
+void comprobe_infopoint_add_display (int infoptrank,
+				     comprobe_infodisplay_fun_t * dispfun,
+				     const char *msg, HOST_WIDE_INT data);
+
+/* displayer routines can add navigators */
+void comprobe_display_add_navigator (struct comprobe_infodisplay_st *idi,
+				     comprobe_infodisplay_fun_t * navfun,
+				     const char *msg, HOST_WIDE_INT data);
+
+
+/***
+ * verb handler registration (the verb and data should be constant or
+ * global data, or explicitly allocated at registration and freed
+ * after unregistration).
+ ***/
+void comprobe_register (const char *verb, comprobe_requestfun_t * handler,
+			void *data);
+/* unregistration is not yet imlemented */
+void comprobe_unregister (const char *verb);
+
+typedef HOST_WIDE_INT comprobe_ix_t;
+
+/***************************************************************************
+ * additional tree specific routines are declared only if we know
+ * about trees because this file has been included after tree.h
+ *******/
+#ifdef TREE_CODE		/*TREE_CODE is an important macro from tree.h */
+
+/***
+ * return true if a (GIMPLE/SSA) tree TR has a position 
+ * and in that case fill the PFILENAME and PLINENO
+ * if the END flag is set, return the last position
+ ***/
+enum { POS_START = 0, POS_END };
+bool comprobe_get_position (tree tr, char **pfilename, int *plineno, int end);
+
+/***
+ * return a unique positive file rank for the location of a tree, if
+ * any (else 0); may send a PROB_file request to the probe and set the
+ * *plineno to the line number
+ **/
+int comprobe_file_rank_of_tree (tree tr, int *plineno);
+
+/****
+ * we manage a unique mapping between trees and indexes thru our hash
+ * table; to get the index of a tree and vice versa the tree of an
+ * index
+ ***/
+comprobe_ix_t comprobe_unique_index_of_tree (tree tr);
+tree comprobe_tree_of_unique_index (comprobe_ix_t ix);
+
+#endif /*TREE_CODE */
+
+
+
+
+/************************************************************************
+ * additional basic block specific routines are declared only if
+ * we know about basic blocks because "basic-block.h" have been included
+ ************************************************************************/
+#ifdef BASIC_BLOCK		/* an important macro of basic-block */
+/****
+ * we manage a unique mapping between basic blocks and indexes thru
+ * our hash table; to get the index of a basic block and vice versa
+ * the basic block of an index
+ ***/
+comprobe_ix_t comprobe_unique_index_of_basic_block (basic_block bb);
+basic_block comprobe_basic_block_of_unique_index (comprobe_ix_t ix);
+#endif
+
+#else /* compiler probe disabled */
+
+/***************** fake stubs when probe disabled *******************/
+#define comprobe_check(WHAT) do{}while(0)
+#define comprobe_while(WHAT,PVAR)  do{}while(0)
+#define comprobe_stop() do{}while(0)
+#define comprobe_forced_kill() do{}while(0)
+#define comprobe_flush() do{}while(0)
+#define comprobe_replf  ((FILE*)0)
+#define comprobe_show_message(M) do{if(0) puts(M);}while(0)
+#define comprobe_puts(S) do[}while(0)
+#define comprobe_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_big_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_register(Verb,Hdlr,Data) do{}while(0)
+#define comprobe_unregister(Verb,Hdlr,Data) do{}while(0)
+#define comprobe_begin_big()
+#define comprobe_begin_big_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_end_big()
+#define comprobe_outenc_string(S) do{if (0 && ((S) == (char*)0));}while(0)
+#define comprobe_filerank_of_tree(T,P)  (0 && (T) == (tree)0 && (P) == (int*)0)
+#define comprobe_unique_index_of_tree(T) (0 && (T) == (tree)0)
+#define comprobe_tree_of_unique_index(I) NULL_TREE
+#define comprobe_filerank(P)  (0 && (P) == (const char*)0)
+#define comprobe_get_position(T,PF,PL,E) (FALSE \
+					  && (T)!=(tree)0 \
+					  && (PF)!=(char**0) \
+					  && (PL) != (int*)0 && (E))
+#define  comprobe_infopoint_add_displayer(IRK,DMESG,DROUT,DATA) while(0 && \
+  (IRK) != (int)0 && (DMESG) != (char*)0 && \
+  (DROUT) != (comprobe_infoptdisplayroutine_t*)0 && (DATA) != (void*)0) {}
+#endif /*ENABLE_COMPILER_PROBE */
+
+#endif /*GCC_COMPILER_PROBE_H */
+/* Compiler probe.
+   Copyright (C) 2007 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch  <basile@starynkevitch.net>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GCC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+#ifndef GCC_COMPILER_PROBE_H
+#define GCC_COMPILER_PROBE_H
+
+#define COMPROBE_PROTOCOL_NUMBER 200701
+
+/* the compiler probe */
+#if defined(ENABLE_COMPILER_PROBE) && ENABLE_COMPILER_PROBE
+/* <unistd.h> and <fcntl.h> and <string.h> have already been included
+   and the following includes have been checked by autoconf */
+#include <sys/select.h>
+#include <signal.h>
+
+/* compiler-probe.c uses the comprobe_ prefix */
+
+struct comprobe_whatpos_st
+{
+  const char *wp_what;
+  const char *wp_file;
+  int wp_line;
+};
+
+/* handling routine for a request (from probe to compiler) */
+typedef void comprobe_requestfun_t (struct comprobe_whatpos_st *wp,
+				    char *reqlin, void *data);
+
+/****
+ * the interrupt flag, its handler, and the macro to check it 
+ ****/
+extern volatile sig_atomic_t comprobe_interrupted;
+
+void comprobe_handle_probe (const char *what, const char *file, int lineno);
+
+/* this macro should be put at all the points where we want to permit
+   compiler probe interaction; in the common case where
+   comprobe_interrupted is cleared, this macro runs quite quickly */
+#define comprobe_check(WHAT) do{ if (comprobe_interrupted) { \
+      comprobe_handle_probe((WHAT),__FILE__,__LINE__); }} while(0)
+
+/***
+ * stop the compiler probe (can be called from action handler)
+ ***/
+void comprobe_stop (void);
+
+/***
+ * forced kill of the compiler probe
+ ***/
+void comprobe_forced_kill (void);
+
+/* force probing till an integer variable is cleared or the probe ended */
+void comprobe_while_probe (const char *what, const char *file, int lineno,
+			   int *pvar);
+#define comprobe_while(WHAT,PVAR) do{ \
+    comprobe_while_probe((WHAT),__FILE__,__LINE__,(PVAR));}while(0)
+/***
+ * the stream for replying to the probe ; may be NULL so should be tested!
+ ***/
+extern FILE *comprobe_replf;
+#define comprobe_printf(Fmt, ...) do{if(comprobe_replf) {	\
+      fprintf(comprobe_replf, (Fmt), ##__VA_ARGS__);		\
+      fflush(comprobe_replf);}}while(0)
+#define comprobe_flush() do{if(comprobe_replf)	\
+      fflush(comprobe_replf); } while(0)
+void comprobe_begin_big (void);
+void comprobe_end_big (void);
+void comprobe_outenc_string (const char *s);
+#define comprobe_begin_big_printf(Fmt, ...) do{if(comprobe_replf) {	\
+      comprobe_begin_big(); fprintf(comprobe_replf, (Fmt), \
+				    ##__VA_ARGS__);}}while(0)
+/***
+ * initialize and finish. called in toplev.c 
+ ****/
+void comprobe_initialize (void);
+void comprobe_finish (void);
+
+
+/****
+ * send a message to be shown
+ ****/
+void comprobe_show_message (const char *msg);
+
+
+extern struct tree_opt_pass pass_compiler_probe;
+
+/***
+ * return a unique positive file rank for a file path; or 0 for NULL name
+ *  may send a PROB_file request to the probe
+ ***/
+int comprobe_file_rank (const char *filename);
+
+/***
+ * return a unique positive infopoint rank for a file rank and a line
+ * number; may send a PROB_file request and a PROB_infopoint request
+ * to the probe
+ **/
+int comprobe_infopoint_rank (int filrank, int lineno);
+
+/***
+ * return the linenumber, filerank, and filename of a given infopoint
+ * or O|NULL if invalid infopoint rank
+ ***/
+int comprobe_line_of_infopoint (int infoptrank);
+int comprobe_filerank_of_infopoint (int infoptrank);
+const char *comprobe_filename_of_infopoint (int infoptrank);
+
+/***
+ * infopoint displayer routines
+ ***/
+
+/* info displayers are opaque structures managed by the compiler probe */
+struct comprobe_infodisplay_st;
+
+typedef void comprobe_infodisplay_fun_t
+  (struct comprobe_whatpos_st *wp,
+   struct comprobe_infodisplay_st *di,
+   HOST_WIDE_INT data, HOST_WIDE_INT navig);
+
+void comprobe_infopoint_add_display (int infoptrank,
+				     comprobe_infodisplay_fun_t * dispfun,
+				     const char *msg, HOST_WIDE_INT data);
+
+/* displayer routines can add navigators */
+void comprobe_display_add_navigator (struct comprobe_infodisplay_st *idi,
+				     comprobe_infodisplay_fun_t * navfun,
+				     const char *msg, HOST_WIDE_INT data);
+
+
+/***
+ * verb handler registration (the verb and data should be constant or
+ * global data, or explicitly allocated at registration and freed
+ * after unregistration).
+ ***/
+void comprobe_register (const char *verb, comprobe_requestfun_t * handler,
+			void *data);
+/* unregistration is not yet imlemented */
+void comprobe_unregister (const char *verb);
+
+typedef HOST_WIDE_INT comprobe_ix_t;
+
+/***************************************************************************
+ * additional tree specific routines are declared only if we know
+ * about trees because this file has been included after tree.h
+ *******/
+#ifdef TREE_CODE		/*TREE_CODE is an important macro from tree.h */
+
+/***
+ * return true if a (GIMPLE/SSA) tree TR has a position 
+ * and in that case fill the PFILENAME and PLINENO
+ * if the END flag is set, return the last position
+ ***/
+enum { POS_START = 0, POS_END };
+bool comprobe_get_position (tree tr, char **pfilename, int *plineno, int end);
+
+/***
+ * return a unique positive file rank for the location of a tree, if
+ * any (else 0); may send a PROB_file request to the probe and set the
+ * *plineno to the line number
+ **/
+int comprobe_file_rank_of_tree (tree tr, int *plineno);
+
+/****
+ * we manage a unique mapping between trees and indexes thru our hash
+ * table; to get the index of a tree and vice versa the tree of an
+ * index
+ ***/
+comprobe_ix_t comprobe_unique_index_of_tree (tree tr);
+tree comprobe_tree_of_unique_index (comprobe_ix_t ix);
+
+#endif /*TREE_CODE */
+
+
+
+
+/************************************************************************
+ * additional basic block specific routines are declared only if
+ * we know about basic blocks because "basic-block.h" have been included
+ ************************************************************************/
+#ifdef BASIC_BLOCK		/* an important macro of basic-block */
+/****
+ * we manage a unique mapping between basic blocks and indexes thru
+ * our hash table; to get the index of a basic block and vice versa
+ * the basic block of an index
+ ***/
+comprobe_ix_t comprobe_unique_index_of_basic_block (basic_block bb);
+basic_block comprobe_basic_block_of_unique_index (comprobe_ix_t ix);
+#endif
+
+#else /* compiler probe disabled */
+
+/***************** fake stubs when probe disabled *******************/
+#define comprobe_check(WHAT) do{}while(0)
+#define comprobe_while(WHAT,PVAR)  do{}while(0)
+#define comprobe_stop() do{}while(0)
+#define comprobe_forced_kill() do{}while(0)
+#define comprobe_flush() do{}while(0)
+#define comprobe_replf  ((FILE*)0)
+#define comprobe_show_message(M) do{if(0) puts(M);}while(0)
+#define comprobe_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_big_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_register(Verb,Hdlr,Data) do{}while(0)
+#define comprobe_unregister(Verb,Hdlr,Data) do{}while(0)
+#define comprobe_begin_big()
+#define comprobe_begin_big_printf(Fmt, ...) do{if(0) printf((Fmt),##__VA_ARGS__);}while(0)
+#define comprobe_end_big()
+#define comprobe_outenc_string(S) do{if (0 && ((S) == (char*)0));}while(0)
+#define comprobe_filerank_of_tree(T,P)  (0 && (T) == (tree)0 && (P) == (int*)0)
+#define comprobe_unique_index_of_tree(T) (0 && (T) == (tree)0)
+#define comprobe_tree_of_unique_index(I) NULL_TREE
+#define comprobe_filerank(P)  (0 && (P) == (const char*)0)
+#define comprobe_get_position(T,PF,PL,E) (FALSE \
+					  && (T)!=(tree)0 \
+					  && (PF)!=(char**0) \
+					  && (PL) != (int*)0 && (E))
+#define  comprobe_infopoint_add_displayer(IRK,DMESG,DROUT,DATA) while(0 && \
+  (IRK) != (int)0 && (DMESG) != (char*)0 && \
+  (DROUT) != (comprobe_infoptdisplayroutine_t*)0 && (DATA) != (void*)0) {}
+#endif /*ENABLE_COMPILER_PROBE */
+
+#endif /*GCC_COMPILER_PROBE_H */
diff --git a/gcc/config.in b/gcc/config.in
index 723b88fc8e7..49007bd346a 100644
--- a/gcc/config.in
+++ b/gcc/config.in
@@ -46,6 +46,12 @@
 #endif
 
 
+/* Define if compiler probe is enabled. */
+#ifndef USED_FOR_TARGET
+#undef ENABLE_COMPILER_PROBE
+#endif
+
+
 /* Define to 1 to specify that we are using the BID decimal floating point
    format instead of DPD */
 #ifndef USED_FOR_TARGET
@@ -1026,6 +1032,12 @@
 #endif
 
 
+/* Define if Libtool dynamic linker is in use. */
+#ifndef USED_FOR_TARGET
+#undef HAVE_LIBTOOLDYNL
+#endif
+
+
 /* Define to 1 if you have the <limits.h> header file. */
 #ifndef USED_FOR_TARGET
 #undef HAVE_LIMITS_H
@@ -1104,6 +1116,12 @@
 #endif
 
 
+/* Define if Parma Polyhedra Library is in use. */
+#ifndef USED_FOR_TARGET
+#undef HAVE_PARMAPOLY
+#endif
+
+
 /* Define to 1 if you have the `putchar_unlocked' function. */
 #ifndef USED_FOR_TARGET
 #undef HAVE_PUTCHAR_UNLOCKED
diff --git a/gcc/configure.ac b/gcc/configure.ac
index f3bc7b352c5..d230bcb59a7 100644
--- a/gcc/configure.ac
+++ b/gcc/configure.ac
@@ -308,6 +308,212 @@ AC_CHECK_SIZEOF(long)
 AC_CHECK_TYPES([long long], [AC_CHECK_SIZEOF(long long)])
 AC_CHECK_TYPES([__int64], [AC_CHECK_SIZEOF(__int64)])
 
+################################################
+##### Basilys specific stuff
+
+################
+# Check for PPL (Parma Polyhedral Library)
+ppllibs=
+pplinc=
+have_ppl=yes
+
+AC_ARG_WITH(ppl, [  --with-ppl=PATH        Specify prefix directory for installed Parma Polyedra Library (PPL)
+                          Equivalent to --with-ppl-include=PATH/include
+                          plus --with-ppl-lib=PATH/lib])
+AC_ARG_WITH(ppl_include, [  --with-ppl-include=PATH Specify directory for installed PPL include files])
+AC_ARG_WITH(ppl_lib, [  --with-ppl-lib=PATH     Specify the directory for the installed PPL library])
+
+
+if test "x$with_ppl" != x; then
+  ppllibs="-L$with_ppl/lib -lppl_c -lppl  $ppllibs"
+  pplinc="-I$with_ppl/include"
+fi
+
+if test "x$ppl_include" != x; then
+  pplinc="-I$ppl_include $pplinc"
+fi
+
+if test "x$ppl_lib" != x; then
+   ppllibs="-L$ppl_lib -lppl_c -lppl  $ppllibs"
+fi
+
+## check for Parma Polyedra Lib
+saved_CFLAGS="$CFLAGS"
+saved_LIBS="$LIBS"
+CFLAGS="$CFLAGS $pplinc $gmpinc $ppllibs $gmplibs"
+AC_MSG_CHECKING([for correct version of ppl_c.h])
+AC_TRY_LINK([#include <ppl_c.h>],[
+ppl_version_major(); ], [AC_MSG_RESULT([yes]); have_ppl=yes], [AC_MSG_RESULT([no]); have_ppl=no])
+
+# one some systems, PPL requires an additional C++ wrapping library for GMP 
+# namely -lgmpxx ahead of -lgmp
+if test x"$have_ppl" != xyes; then
+  saved_LIBS="$LIBS"
+  ppllibs="-lgmpxx $ppllibs"
+  #maybe we should do:: gmplibs=`echo "$gmplibs" | sed -e 's/-lgmp/-lgmpxx -lgmp/'`
+  CFLAGS="$CFLAGS $pplinc $gmpinc $ppllibs $gmplibs"
+  AC_MSG_CHECKING([for libgmpxx needed by ppl])
+  AC_TRY_LINK([#include <ppl_c.h>],[
+  ppl_version_major(); ], [AC_MSG_RESULT([yes]); have_ppl=yes], [AC_MSG_RESULT([no]); have_ppl=no])
+fi
+if test x"$have_ppl" = xyes; then
+  AC_DEFINE(HAVE_PARMAPOLY, 1, [Define if Parma Polyhedra Library is in use.])
+fi
+LIBS="$saved_LIBS"
+CFLAGS="$saved_CFLAGS"
+
+if test -d ${srcdir}/gcc && test x$have_ppl != xyes; then
+  AC_MSG_WARN([Some passes of GCC require PPL 0.9+.
+Try the --with-ppl option to specify the installed PPL location,
+or specify separately --with-ppl-include=DIRINCL  --with-ppl-lib=DIRLIB.
+Copies of this library source code can be found at its respective
+hosting site as well as at ftp://gcc.gnu.org/pub/gcc/infrastructure/.
+See also http://gcc.gnu.org/install/prerequisites.html for additional info.])
+fi
+
+# Flags needed for PPL
+AC_SUBST(ppllibs)
+AC_SUBST(pplinc)
+ 
+
+
+################
+# Check for LTDL (Libtool dynamic loader)
+ltdllibs="-lltdl"
+ltdlinc=
+have_ltdl=yes
+
+AC_ARG_WITH(ltdl, [  --with-ltdl=PATH        Specify prefix directory for installed LibTool Dynamic Loader library
+                          Equivalent to --with-ltdl-include=PATH/include
+                          plus --with-ltdl-lib=PATH/lib])
+
+AC_ARG_WITH(ltdl_include, [  --with-ltdl-include=PATH Specify directory for installed LTDL include files])
+AC_ARG_WITH(ltdl_lib, [  --with-ltdl-lib=PATH     Specify the directory for the installed LTDL library])
+
+
+if test "x$with_ltdl" != x; then
+  ltdllibs="-L$with_ltdl/lib -lltdl"
+  ltdlinc="-I$with_ltdl/include"
+fi
+
+if test "x$ltdl_include" != x; then
+  ltdlinc="-I$ltdl_include $ltdlinc"
+fi
+
+if test "x$ltdl_lib" != x; then
+   ltdllibs="-L$ltdl_lib -lltdl  $ltdllibs"
+fi
+
+ltdl_ldflags=""
+
+saved_CFLAGS="$CFLAGS"
+saved_LIBS="$LIBS"
+saved_LDFLAGS="$LD_FLAGS"
+CFLAGS="$CFLAGS $ltdlinc"
+LIBS="$LIBS $ltdllibs"
+LDFLAGS="$LDFLAGS -rdynamic"
+AC_MSG_CHECKING([for  LibTool Dynamic Loader])
+AC_TRY_LINK([#include <ltdl.h>],[
+  lt_dlhandle h;
+  lt_dlinit ();
+  h = lt_dlopen ((const char *)0);
+], [AC_MSG_RESULT([yes]); have_ltdl=yes], [AC_MSG_RESULT([no]); have_ltdl=no])
+
+if test "x$have_ltdl" != xyes; then
+  AC_MSG_WARN([Some passes of GCC require LibTool Dynamic Loader.
+Try the --with-ltdl option to specify the installed LTDL location.
+Copies of this library source code can be found at its respective
+hosting site as well as at ftp://gcc.gnu.org/pub/gcc/infrastructure/.
+See also http://gcc.gnu.org/install/prerequisites.html for additional info.])
+else
+   AC_DEFINE(HAVE_LIBTOOLDYNL, 1,
+	     [Define if Libtool dynamic linker is in use.])
+   ltdl_ldflags="-rdynamic"
+fi
+
+CFLAGS="$saved_CFLAGS"
+LIBS="$saved_LIBS"
+LDFLAGS="$saved_LDFLAGS"
+
+# Flags needed for LTDL
+AC_SUBST(ltdllibs)
+AC_SUBST(ltdlinc)
+AC_SUBST(ltdl_ldflags)
+
+
+# for debugging only
+echo '%!%' after LTDL LIBS= $LIBS  CFLAGS= $CFLAGS
+
+# ------------------------
+# Compiler probing support
+# ------------------------
+enabled_compiler_probe=no
+
+AC_ARG_ENABLE(compiler-probe,
+[  --enable-compiler-probe        Enable instrumenting probe of compiler
+                                  only useful for compiler hackers or
+				  users expecting huge compilation times;
+				  this could slow down the compiler
+				  [hence is disabled by default].
+],
+enabled_compiler_probe=$enableval,
+enabled_compiler_probe=no)
+
+if test "$enabled_compiler_probe" = "yes" ; then
+   AC_MSG_CHECKING([for features required for compiler probe])
+## we check specifically for the Posix/SuS (Single Unix Spec) select,
+## for the SIGPOLL SuS signal handled by SuS sigaction
+## and for fcntl F_SETOWN available in Linux, *BSD, Solaris
+AC_TRY_COMPILE([
+/* testing features for compiler probe */
+#include <unistd.h>
+#include <fcntl.h>
+#include <sys/select.h>
+#include <signal.h>
+#include <string.h>
+
+volatile sig_atomic_t my_flag;
+static void my_signal_handler(int sig) 
+{if (sig == SIGPOLL) my_flag=1;}
+],
+[
+  fd_set rfs;
+  int fd = 1;
+  struct timeval tv;
+  struct sigaction sa;
+  FD_ZERO (&rfs);
+  FD_SET (0, &rfs);
+  tv.tv_sec = 0;
+  tv.tv_usec = 500000;
+  /* Posix/Single Unix Spec select */
+  if (select (1, &rfs, (fd_set *) 0, (fd_set *) 0, &tv))
+    return 0;
+  /* Posix/SuS signal */
+  memset (&sa, 0, sizeof (sa));
+  sa.sa_handler = my_signal_handler;
+  if (sigaction (SIGPOLL, &sa, (struct sigaction *) 0))
+    return 0;
+  /* Linux, Solaris, and most BSD have F_SETOWN */
+  if (fcntl (fd, F_SETOWN, (long) getpid ()))
+    return 0;
+  return 0;
+],
+[AC_MSG_RESULT([yes]);
+ enabled_compiler_probe=yes;
+ AC_DEFINE(ENABLE_COMPILER_PROBE, 1, [Define if compiler probe is enabled.])
+ COMPILER_PROBE=compiler-probe.o
+], 
+[AC_MSG_RESULT([no]); 
+ AC_MSG_WARN([Your system lacks the required features for compiler probing.
+                Hence compiler probe is disabled.]);
+ enabled_compiler_probe=no]
+);
+fi
+
+AC_SUBST(COMPILER_PROBE)
+###################### end of basilys specific stuff
+
+
 # ---------------------
 # Warnings and checking
 # ---------------------
diff --git a/gcc/diagnostic.c b/gcc/diagnostic.c
index 6bbfe9a36e7..c05a8ccc415 100644
--- a/gcc/diagnostic.c
+++ b/gcc/diagnostic.c
@@ -41,6 +41,8 @@ along with GCC; see the file COPYING3.  If not see
 #include "langhooks-def.h"
 #include "opts.h"
 
+#include "compiler-probe.h"
+/* we just need to kill the compiler probe on internal|fatal errors */
 
 /* Prototypes.  */
 static char *build_message_string (const char *, ...) ATTRIBUTE_PRINTF_1;
@@ -588,6 +590,8 @@ fatal_error (const char *gmsgid, ...)
   report_diagnostic (&diagnostic);
   va_end (ap);
 
+  comprobe_forced_kill();
+
   gcc_unreachable ();
 }
 
@@ -606,6 +610,8 @@ internal_error (const char *gmsgid, ...)
   report_diagnostic (&diagnostic);
   va_end (ap);
 
+  comprobe_forced_kill();
+  
   gcc_unreachable ();
 }
 
diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
index e8d10e236c4..b90287d4168 100644
--- a/gcc/gdbinit.in
+++ b/gcc/gdbinit.in
@@ -129,6 +129,17 @@ document pbm
 Dump the bitmap that is in $ as a comma-separated list of numbers.
 end
 
+## for basilys
+set breakpoint pending	on
+define pby
+set basilys_dbgeprint ($)
+end
+
+document pby
+Print the basilys_ptr_t that is $.
+Works only when an inferior is executing.
+end
+
 # Put breakpoints at exit and fancy_abort in case abort is mapped
 # to either fprintf/exit or fancy_abort.
 b fancy_abort
diff --git a/gcc/gengtype.c b/gcc/gengtype.c
index ca7d5b411cd..7261e71f61f 100644
--- a/gcc/gengtype.c
+++ b/gcc/gengtype.c
@@ -1535,7 +1535,9 @@ open_base_files (void)
       "hard-reg-set.h", "basic-block.h", "cselib.h", "insn-addr.h",
       "optabs.h", "libfuncs.h", "debug.h", "ggc.h", "cgraph.h",
       "tree-flow.h", "reload.h", "cpp-id-data.h", "tree-chrec.h",
-      "cfglayout.h", "except.h", "output.h", "cfgloop.h", NULL
+      "cfglayout.h", "except.h", "output.h", "cfgloop.h", 
+      "basilys.h",
+      NULL
     };
     const char *const *ifp;
     outf_p gtype_desc_c;
diff --git a/gcc/params.def b/gcc/params.def
index 0428c3120af..c7a0513e136 100644
--- a/gcc/params.def
+++ b/gcc/params.def
@@ -708,6 +708,22 @@ DEFPARAM (PARAM_USE_CANONICAL_TYPES,
 	  "Whether to use canonical types",
 	  1, 0, 1)
 
+/**** stuff for Basilys runtime */
+
+/* the Basilys minor zone size for its own copying garbage collector */
+DEFPARAM (PARAM_BASILYS_MINOR_ZONE,
+	 "basilys-minor-zone",
+	 "size in kilowords (one word = one pointer) of the minor zone for the specialized copying basilys collector",
+	 256, 128, 32768)
+
+/* paramater tuning the frequency of full garbage collection in Basilys */
+DEFPARAM (PARAM_BASILYS_FULL_FREQ,
+	 "basilys-full-freq",
+	 "tuning the frequency of full garbage collection in the specialized basilys collector",
+	 16, 8, 128)
+/**** end of Basilys stuff */
+
+
 DEFPARAM (PARAM_MAX_PARTIAL_ANTIC_LENGTH,
 	  "max-partial-antic-length",
 	  "Maximum length of partial antic set when performing tree pre optimization",
diff --git a/gcc/passes.c b/gcc/passes.c
index 2614c90b3ca..af499a80ed2 100644
--- a/gcc/passes.c
+++ b/gcc/passes.c
@@ -102,6 +102,9 @@ along with GCC; see the file COPYING3.  If not see
 				   declarations for e.g. AIX 4.x.  */
 #endif
 
+
+#include "compiler-probe.h"
+
 /* This is used for debugging.  It allows the current pass to printed
    from anywhere in compilation.  */
 struct tree_opt_pass *current_pass;
@@ -546,7 +549,8 @@ init_optimization_passes (void)
   NEXT_PASS (pass_ipa_pure_const); 
   NEXT_PASS (pass_ipa_type_escape);
   NEXT_PASS (pass_ipa_pta);
-  NEXT_PASS (pass_ipa_struct_reorg);  
+  NEXT_PASS (pass_ipa_struct_reorg); 
+  NEXT_PASS (pass_basilys); 
   *p = NULL;
 
   /* These passes are run after IPA passes on every function that is being
@@ -677,6 +681,11 @@ init_optimization_passes (void)
       NEXT_PASS (pass_mark_used_blocks);
       NEXT_PASS (pass_cleanup_cfg_post_optimizing);
     }
+
+#if ENABLE_COMPILER_PROBE
+  NEXT_PASS(pass_compiler_probe);
+#endif
+
   NEXT_PASS (pass_warn_function_noreturn);
   NEXT_PASS (pass_free_datastructures);
   NEXT_PASS (pass_mudflap_2);
@@ -1065,6 +1074,10 @@ execute_one_pass (struct tree_opt_pass *pass)
 {
   bool initializing_dump;
   unsigned int todo_after = 0;
+#if ENABLE_COMPILER_PROBE
+  static char cprobuf[80];
+  memset(cprobuf, 0, sizeof(cprobuf));
+#endif
 
   current_pass = pass;
   /* See if we're supposed to run this pass.  */
@@ -1089,6 +1102,13 @@ execute_one_pass (struct tree_opt_pass *pass)
 		   (void *)(size_t)pass->properties_required);
 #endif
 
+  if (pass->name && comprobe_replf) {
+    static char buf[80];
+    memset(buf, 0, sizeof(buf));
+    snprintf(buf, sizeof(buf)-1, "pass %s", pass->name);
+    comprobe_show_message(buf);
+  }
+
   /* If a dump file name is present, open it if enabled.  */
   if (pass->static_pass_number != -1)
     {
@@ -1119,7 +1139,15 @@ execute_one_pass (struct tree_opt_pass *pass)
   /* Do it!  */
   if (pass->execute)
     {
+      comprobe_check((snprintf(cprobuf, sizeof(cprobuf)-1, 
+			       "pass %s before execute", 
+			       pass->name?pass->name:"_"),
+		      cprobuf));
       todo_after = pass->execute ();
+      comprobe_check((snprintf(cprobuf, sizeof(cprobuf)-1, 
+			       "pass %s executed", 
+			       pass->name?pass->name:"_"),
+		      cprobuf));
       do_per_function (clear_last_verified, NULL);
     }
 
diff --git a/gcc/run-basilys.h b/gcc/run-basilys.h
new file mode 100644
index 00000000000..80c728f93f1
--- /dev/null
+++ b/gcc/run-basilys.h
@@ -0,0 +1,63 @@
+/* Basile's static analysis (should have a better name) run-basilys.h
+   all include files for generated code
+   
+   Copyright 2008 Free Software Foundation, Inc.
+   Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+   Indented with GNU indent 
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GCC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "obstack.h"
+#include "tm.h"
+#include "tree.h"
+#include "tree-pass.h"
+#include "tree-dump.h"
+#include "basic-block.h"
+#include "timevar.h"
+#include "errors.h"
+#include "ggc.h"
+#include "cgraph.h"
+#include "diagnostic.h"
+#include "flags.h"
+#include "toplev.h"
+#include "options.h"
+#include "params.h"
+#include "real.h"
+#include "prefix.h"
+
+#include "compiler-probe.h"
+
+
+#if HAVE_PARMAPOLY
+#include <ppl_c.h>
+#else
+#error required parma polyedral library PPL
+#endif /*HAVE_PARMAPOLY */
+
+#if HAVE_LIBTOOLDYNL
+#include <ltdl.h>
+#else
+#error required libtool dynamic loader library LTDL
+#endif /*HAVE_LIBTOOLDYNL */
+
+#include "basilys.h"
diff --git a/gcc/system.h b/gcc/system.h
index 568bd751a4c..8131d28aebd 100644
--- a/gcc/system.h
+++ b/gcc/system.h
@@ -349,6 +349,15 @@ extern int errno;
 #define WCOREFLG 0200
 #endif
 
+
+/* the compiler probe */
+#if defined(ENABLE_COMPILER_PROBE) && ENABLE_COMPILER_PROBE
+/* <unistd.h> and <fcntl.h> and <string.h> have already been included
+   and the following includes have been checked by autoconf */
+#include <sys/select.h>
+#include <signal.h>
+#endif
+
 /* The HAVE_DECL_* macros are three-state, undefined, 0 or 1.  If they
    are defined to 0 then we must provide the relevant declaration
    here.  These checks will be in the undefined state while configure
diff --git a/gcc/timevar.def b/gcc/timevar.def
index e503894677b..6d9888b2425 100644
--- a/gcc/timevar.def
+++ b/gcc/timevar.def
@@ -192,5 +192,8 @@ DEFTIMEVAR (TV_SYMOUT                , "symout")
 DEFTIMEVAR (TV_VAR_TRACKING          , "variable tracking")
 DEFTIMEVAR (TV_TREE_IFCOMBINE        , "tree if-combine")
 
+/* Basilys needs */
+DEFTIMEVAR (TV_BASILE_ANALYSIS       , "Basile's analysis")
+
 /* Everything else in rest_of_compilation not included above.  */
 DEFTIMEVAR (TV_REST_OF_COMPILATION   , "rest of compilation")
diff --git a/gcc/toplev.c b/gcc/toplev.c
index 512e0fb8708..7064c7e2876 100644
--- a/gcc/toplev.c
+++ b/gcc/toplev.c
@@ -32,6 +32,15 @@ along with GCC; see the file COPYING3.  If not see
 #include "tm.h"
 #include <signal.h>
 
+/* Basilys needs the Parma Polyhedral Library & the Libtool dynamic loader */
+#if HAVE_PARMAPOLY 
+#include <ppl_c.h>
+#endif 
+
+#if HAVE_LIBTOOLDYNL
+#include <ltdl.h>
+#endif 
+
 #ifdef HAVE_SYS_RESOURCE_H
 # include <sys/resource.h>
 #endif
@@ -81,6 +90,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "value-prof.h"
 #include "alloc-pool.h"
 #include "tree-mudflap.h"
+#include "compiler-probe.h"
 #include "tree-pass.h"
 
 #if defined (DWARF2_UNWIND_INFO) || defined (DWARF2_DEBUGGING_INFO)
@@ -100,6 +110,11 @@ along with GCC; see the file COPYING3.  If not see
 				   declarations for e.g. AIX 4.x.  */
 #endif
 
+/* we don't include basilys.h but declare its initializer here */
+#if HAVE_LIBTOOLDYNL && HAVE_PARMAPOLY
+extern void basilys_initialize(void); /* in basilys.c */
+#endif
+
 static void general_init (const char *);
 static void do_compile (void);
 static void process_options (void);
@@ -1669,6 +1684,19 @@ general_init (const char *argv0)
   line_table->reallocator = realloc_for_line_map;
   init_ttree ();
 
+  /* Basilys needs PARMAPOLY & LIBTOOLDYNL */
+#if HAVE_PARMAPOLY
+  /* Initialize the Parma Polyhedra Library. */
+  if (ppl_initialize () <0) 
+    fatal_error ("failed to initialize Parma Polyedra Library");
+#endif
+
+#if HAVE_LIBTOOLDYNL
+  /* Initialize the Libtool Dynamic Loader */
+  if (lt_dlinit() > 0)
+    fatal_error ("failed to initialize Libtool Dynamic Loader");
+#endif
+
   /* Initialize register usage now so switches may override.  */
   init_reg_sets ();
 
@@ -2242,6 +2270,12 @@ do_compile (void)
       if (!no_backend)
 	backend_init ();
 
+#if ENABLE_COMPILER_PROBE
+      /* just to be sure the probe loads the input file */
+      (void) comprobe_file_rank(main_input_filename);
+#endif
+
+
       /* Language-dependent initialization.  Returns true on success.  */
       if (lang_dependent_init (main_input_filename))
 	compile_file ();
@@ -2274,10 +2308,27 @@ toplev_main (unsigned int argc, const char **argv)
 
   init_local_tick ();
 
+#if ENABLE_COMPILER_PROBE
+  /* Initialize the compiler probe (may install a SIGIO handler and
+     uses the random seed) */
+  comprobe_initialize();
+#endif
+
+#if HAVE_LIBTOOLDYNL && HAVE_PARMAPOLY
+  /* initialize basilys if needed */
+  if (flag_basilys)
+    basilys_initialize();
+#endif
+
   /* Exit early if we can (e.g. -help).  */
   if (!exit_after_options)
     do_compile ();
 
+#if ENABLE_COMPILER_PROBE
+  /* Finish the compiler probe (may wait) */
+  comprobe_finish();
+#endif
+
   if (errorcount || sorrycount)
     return (FATAL_EXIT_CODE);
 
diff --git a/gcc/tree-flow-inline.h b/gcc/tree-flow-inline.h
index 1afbd1a8fc7..75288e991cb 100644
--- a/gcc/tree-flow-inline.h
+++ b/gcc/tree-flow-inline.h
@@ -609,7 +609,7 @@ addresses_taken (tree stmt)
 static inline tree
 phi_nodes (const_basic_block bb)
 {
-  gcc_assert (!(bb->flags & BB_RTL));
+  gcc_assert (comprobe_bb_ok_rtl || !(bb->flags & BB_RTL));
   if (!bb->il.tree)
     return NULL;
   return bb->il.tree->phi_nodes;
@@ -620,7 +620,7 @@ phi_nodes (const_basic_block bb)
 static inline tree *
 phi_nodes_ptr (basic_block bb)
 {
-  gcc_assert (!(bb->flags & BB_RTL));
+  gcc_assert (comprobe_bb_ok_rtl || !(bb->flags & BB_RTL));
   return &bb->il.tree->phi_nodes;
 }
 
@@ -631,7 +631,7 @@ set_phi_nodes (basic_block bb, tree l)
 {
   tree phi;
 
-  gcc_assert (!(bb->flags & BB_RTL));
+  gcc_assert (comprobe_bb_ok_rtl || !(bb->flags & BB_RTL));
   bb->il.tree->phi_nodes = l;
   for (phi = l; phi; phi = PHI_CHAIN (phi))
     set_bb_for_stmt (phi, bb);
@@ -711,7 +711,7 @@ phi_ssa_name_p (const_tree t)
 static inline tree
 bb_stmt_list (const_basic_block bb)
 {
-  gcc_assert (!(bb->flags & BB_RTL));
+  gcc_assert (comprobe_bb_ok_rtl || !(bb->flags & BB_RTL));
   return bb->il.tree->stmt_list;
 }
 
@@ -720,7 +720,7 @@ bb_stmt_list (const_basic_block bb)
 static inline void
 set_bb_stmt_list (basic_block bb, tree list)
 {
-  gcc_assert (!(bb->flags & BB_RTL));
+  gcc_assert (comprobe_bb_ok_rtl || !(bb->flags & BB_RTL));
   bb->il.tree->stmt_list = list;
 }
 
diff --git a/gcc/tree-pass.h b/gcc/tree-pass.h
index 01056827c07..06b38929b5c 100644
--- a/gcc/tree-pass.h
+++ b/gcc/tree-pass.h
@@ -343,6 +343,10 @@ extern struct tree_opt_pass pass_early_local_passes;
 extern struct tree_opt_pass pass_ipa_increase_alignment;
 extern struct tree_opt_pass pass_ipa_function_and_variable_visibility;
 
+/* Basilys  passes */
+extern struct tree_opt_pass pass_basilys;
+
+
 extern struct tree_opt_pass pass_all_optimizations;
 extern struct tree_opt_pass pass_cleanup_cfg_post_optimizing;
 extern struct tree_opt_pass pass_free_cfg_annotations;